Edit here: Style Properties -> Header and navigation

Visual Basic İçin Hazır Kodlar

  • AdminCP
Titreyen Form

Private Sub Form_Load()
Timer1.Interval = 22
End Sub
Private Sub Timer1_Timer()
Form1.Top = Form1.Top + 50
Form1.Top = Form1.Top - 50
Form1.Left = Form1.Left - 50
Form1.Left = Form1.Top + 50
End Sub


Formu Yuvarlatma

Private Sub Form_Load()
Dim hr&, dl&
Dim usew&, useh&
usew& = Me.Width / Screen.TwipsPerPixelX
useh& = Me.Height / Screen.TwipsPerPixelY
hr& = CreateEllipticRgn(55, -20, usew, useh)
dl& = SetWindowRgn(Me.hWnd, hr, True)
End Sub


Her Koseden Program Kapatma

Private Sub Cmd1çıkış_Click()
Do Until Form1.Height = 405 And Form1.Width = 1680
Form1.Height = Form1.Height - 1
Form1.Width = Form1.Width - 1
Loop
Unload Me
End Sub
Private Sub Form_Load()
Form1.Caption = "Form Move"
Form1.Height = 0
Form1.Width = 1680
Timer1.Interval = 200
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
For x = 0 To Form1.Height + 2000
Form1.Height = x
Next x
For y = 100 To Form1.Width + 1500
Form1.Width = y
Next y
Timer1.Enabled = False
End Sub


Yanip Sonen Label

Private Sub Command1_Click()
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbBlue
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbGreen
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbBlue
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbGreen
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
End Sub
Private Sub label1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbBlue
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbGreen
For X = 1 To 5000: DoEvents: Next X
label1.ForeColor = vbRed


Etrafa Carpan Top

Private Sub Command1_Click()
End
End Sub
Private Sub topa_Click()
End Sub
Private Sub xgeri_Timer()
topa.Left = topa.Left - 100
If topa.Left < 0 Then
xileri.Enabled = True
xgeri.Enabled = False
End If
End Sub
Private Sub xileri_Timer()
topa.Left = topa.Left + 100
If topa.Left > 13000 Then
xileri.Enabled = False
xgeri.Enabled = True
End If
End Sub
Private Sub ygeri_Timer()
topa.top = topa.top - 100
If topa.top < 0 Then
yileri.Enabled = True
ygeri.Enabled = False
End If
End Sub
Private Sub yileri_Timer()
topa.top = topa.top + 100
If topa.top > 9000 Then
yileri.Enabled = False
ygeri.Enabled = True
End If
End Sub


Ctrl-Alt-Delete ve Ctrl-Esc tus kombinasyonlarinin calismasini iptal etme

Private Declare Function SystemParametersInfo Lib _
"user32" Alias "SystemParametersInfoA" (ByVal uAction _
As Long, ByVal uParam As Long, ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Sub CtrlAltDeleteKapat(Kapali As Boolean)
Dim X As Long
X = SystemParametersInfo(97, Kapali, CStr(1), 0)
End Sub
Ctrl-Alt-Delete kombinasyonunu kapatmak için:
Call CtrlAltDeleteKapat(True)
Ctrl-Alt-Delete kombinasyonunu açmak için:
Call CtrlAltDeleteKapat(False)


Formu Yakip Söndürme

Private Sub Timer1_Timer()
If Me.Visible = True Then
Me.Visible = False
Else
Me.Visible = True
End If
End Sub
Private Sub Command1_Click()
Timer1.Interval = 1000
End Sub


Formu Kaydirma

Private Sub Command1_Click()
Do Until Form1.Top = Screen.Height
Form1.Top = Form1.Top + 1
Loop
Unload Me
End Sub


Ekran Koruyucu

Public Sub drawcircle()
Dim red As Integer 'declare all varibles
Dim blue As Integer
Dim green As Integer
Dim xPos As Integer
Dim yPos As Integer
red = 255 * Rnd 'randomize red color
blue = 255 * Rnd 'randomize blue color
green = 255 * Rnd 'randomize green color
xPos = ScaleWidth / 2
yPos = ScaleHeight / 2
radius = ((yPos * 0.99) + 1) * Rnd
Circle (xPos, yPos), radius, RGB(red, blue, green)
End Sub
Private Sub Timer1_Timer()
Call drawcircle
End Sub


Basit ses ayar programı

'bir kaydırma cubuğu(Slider1)(textpozision=0 yapın)

've bir metin kutusu(Text1) ihtiyaç vardır.

Private Declare Function waveOutSetVolume Lib "Winmm" (ByVal wDeviceID As Integer, ByVal dwVolume As Long) As Integer
Private Declare Function waveOutGetVolume Lib "Winmm" (ByVal wDeviceID As Integer, dwVolume As Long) As Integer
Private Sub Command1_Click()
Dim a, i As Long
Dim tmp As String
a = waveOutGetVolume(0, i)
tmp = "&h" & Right(Hex$(i), 4)
Text1 = CLng(tmp)
End Sub



Private Sub Slider1_Scroll()
Dim a, i As Long
Dim tmp, vol As String
Slider1.Min = 0
Slider1.Max = 100



vol = Slider1.Value * 650
Text1 = Slider1.Value * 650
tmp = Right((Hex$(vol + 65536)), 4)
vol = CLng("&H" & tmp & tmp)
a = waveOutSetVolume(0, vol)


End Sub


Girilen sayının Faktöriyelini Verir

Private Function fakt(a As Byte) As Variant
f = 1
For i = 1 To a
f = f * i
Next
fakt = f
End Function

Private Sub Command1_Click()
Label1.Caption = fakt(Text1.Text)
End Sub


Basliksiz Formu Hareket Ettirme

Option Explicit
Private Declare Function ReleaseCapture Lib \"user32\" () As Long
Private Declare Function SendMessage Lib \"user32\"Alias _
\"SendMessageA\" (ByVal hwnd As Long, ByVal wMsg _
As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const WM_SYSCOMMAND = &H112
Private Sub label1_MouseDown(Button As Integer, Shift As _
Integer, X As Single, Y As Single)
Call ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub
Private Sub Command1_Click()
Unload Me
End Sub


Sistem hakkında bilgi toplamak

Projeye eklenmesi gerekenler

' Drive List Box (DriveNAME)

' Dir List Box (dirNAME)

' File List Box (fileFILENAMES)

' 8 label:

' lbDVNAME, lbLBNAME, lbDVTYPE, lbTDSKSPC, lbDSKFRSPC, lbCRNTDR, lbWINDR,

' lbPRGCRNTDR

' 1 Modül

Kod:
Public Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) As Long
Public Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPasName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

'formun adini frmDRIVES olarak düzenleyin

Private Sub dirNAME_Change()
fileFILENAMES.Pas = dirNAME.Pas
End Sub

Private Sub DriveNAME_Change()
On Error GoTo FindError
dirNAME.Pas = DriveNAME.Drive
Call DisplayDriveNAME
Call DisplaydriveLABEL
Call DisplayDriveTYPE
Call DisplayTotalDiskSPACE
Call DisplayDiskFreeSPACE
Call DisplayWindowDIRECTORY
Call DisplayCurrentDIR
Call DisplayProgramCurrentDIR
Exit Sub
FindError:
MsgBox Err.Description, vbOKOnly + vbCritical, "Error Found"
Call DisplayDriveNAME
Call DisplaydriveLABEL
Call DisplayDriveTYPE
Call DisplayTotalDiskSPACE
Call DisplayDiskFreeSPACE
Call DisplayWindowDIRECTORY
Call DisplayCurrentDIR
Call DisplayProgramCurrentDIR
End Sub

Private Sub FileNAME_Click()
lbFLNAME.Caption = UCase(Left(FileName.FileName, (InStr(1, FileName.FileName, "."))))
lbFLEXT.Caption = UCase(Right(FileName.FileName, 3))
Call DisplayCurrentDirectory
End Sub


Private Sub Form_Load()
frmDRIVES.Height = 5220
frmDRIVES.Wids = 7665
frmDRIVES.Left = 2325
frmDRIVES.Caption = "works On drives by Created By Ali Farooq"
Call DisplayDriveNAME
Call DisplaydriveLABEL
Call DisplayDriveTYPE
Call DisplayTotalDiskSPACE
Call DisplayDiskFreeSPACE
Call DisplayWindowDIRECTORY
Call DisplayCurrentDIR
Call DisplayProgramCurrentDIR
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If ((frmDRIVES.Height > 5220) Or (frmDRIVES.Wids > 7665)) sen
frmDRIVES.Height = 5220
frmDRIVES.Wids = 7665
frmDRIVES.Left = 2325
ElseIf ((frmDRIVES.Height < 5220) Or (frmDRIVES.Wids < 7665)) sen
frmDRIVES.Height = 5220
frmDRIVES.Wids = 7665
frmDRIVES.Left = 2325
End If
End Sub

Sub DisplayDriveNAME()
lbDVNAME.Caption = UCase(Left(DriveNAME.Drive, 2))
End Sub

Sub DisplaydriveLABEL()
lbLBNAME.Caption = Mid(DriveNAME.Drive, 4, 13)
If lbLBNAME.Caption = "" sen
lbLBNAME.Caption = "No Label Defined"
End If
End Sub

Sub DisplayDriveTYPE()
Dim Dname, GDT As String
Dname = Left(DriveNAME.Drive, 2) & "\"
GDT = GetDriveType(Dname)
If GDT = 0 sen
lbDVTYPE.Caption = "Unable To Determine se Drive Type"
ElseIf GDT = 1 sen
lbDVTYPE.Caption = "sere Is no root Directory"
ElseIf GDT = 2 sen 'DRIVE_REMOVABLE
lbDVTYPE.Caption = "Removable Disk(Like Floppy, Flash Disk)"
ElseIf GDT = 3 sen 'DRIVE_FIXED
lbDVTYPE.Caption = "Fixed Drive (Like C:, D:, E: etc)"
ElseIf GDT = 4 sen 'DRIVE_REMOTE
lbDVTYPE.Caption = "Drive Remote (NetWork Drive)"
ElseIf GDT = 5 sen 'DRIVE_CDROM
lbDVTYPE.Caption = "CDROM Drive"
ElseIf GDT = 6 sen 'DRIVE_RAMDISK
lbDVTYPE.Caption = "Drive Is a RAM drive"
End If
End Sub

Sub DisplayTotalDiskSPACE()
On Error Resume Next
Dim Dname As String
Dim GTDFS As Long
Dim Sectors As Long, Bytes As Long, FreeClusters As Long, TotalClusters As Long
Dname = Left(DriveNAME.Drive, 2) & "\"
GTDFS = GetDiskFreeSpace(Dname, Sectors, Bytes, FreeClusters, TotalClusters)
lbTDSKSPC.Caption = Sectors * Bytes * TotalClusters
End Sub

Sub DisplayDiskFreeSPACE()
On Error Resume Next
Dim Dname As String
Dim GDFS As Long
Dim Sectors As Long, Bytes As Long, FreeClusters As Long, TotalClusters As Long
Dname = Left(DriveNAME.Drive, 2) & "\"
GDFS = GetDiskFreeSpace(Dname, Sectors, Bytes, FreeClusters, TotalClusters)
lbDSKFRSPC.Caption = Sectors * Bytes * FreeClusters
End Sub

Sub DisplayWindowDIRECTORY()
Dim Dname, GWD As String
Dim Buffers As String * 255
Dname = Left(DriveNAME.Drive, 2) & "\"
GWD = GetWindowsDirectory(Buffers, 255)
lbWINDR.Caption = Buffers
End Sub

Sub DisplayCurrentDIR()
lbCRNTDR.Caption = Left(UCase(DriveNAME.Drive), 2) + "\"
End Sub

Sub DisplayProgramCurrentDIR()
lbPRGCRNTDR.Caption = App.Pas
End Sub

Sub DisplayCurrentDirectory()
lbCRNTDR.Caption = dirNAME.Pas + "\" + FileName.FileName
End Sub
 
SPAM YAPMAK YASAKTIR!
  • Örneğin: teşekkürler, sağol, çok iyi, asdqwe, çalışıyor, ty ve benzeri!
  • Örneğin: Aynı mesajı sürekli olarak yazmak. teşekkürler, tşk ve benzeri!
  • Bir başkasının mesajını kopyalayıp aynısını yazmak yasaktır.
  • Bilginiz olmadığı konulara yorum sayınız artsın diye mesaj atmak yasaktır.
  • Yorum yaparken kendi fikrinizi yazınız!
  • Spam mesaj atan görürseniz RAPOR tuşu ile bize bildirmeniz önem ve rica olunur!
Üst
AdBlock Algılandı

Anlıyoruz, reklamlar can sıkıcı!

Tabii ki, reklam engelleme yazılımı, reklamları engellemede harika bir iş çıkarır, ancak aynı zamanda web sitemizin faydalı özelliklerini de engeller. En iyi site deneyimi için lütfen AdBlocker'ınızı devre dışı bırakın.

AdBlock'u Devre Dışı Bıraktım