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

INTERNET BAGLANTI BILGILERINI ÖGRENMEK

Internet üzerinden alinan ve gönderilen byte miktarlari Registry icine kaydedilir. Yanliz Bu kod Windows NT altinda calismiyor. Ek olarak transfer hizini ve baglanti hizini da ögrenebiliyoruz.
Option Explicit
Private Declare Function RegOpenKeyEx Lib "advapi32.dll"Alias _
"RegOpenKeyExA" (ByVal hKey As Long, ByVal _
lpSubKey As String, ByVal ulOptions As Long, ByVal _
samDesired As Long, phkResult As Long) As Long
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal _
hKey As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll"Alias _
"RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName _
As String, ByVal lpReserved As Long, lpType As Long, _
lpData As Any, lpcbData As Any) As Long
Const HKEY_DYN_DATA = &H80000006
Const KEY_READ = &H19
Const ERROR_SUCCESS = 0&
Dim s1&, e1&, LBytes&, CNT&, Q&, QQ&, SUM&
Private Sub Command1_Click()
Reset
End Sub
Private Sub Form_Load()
Reset
LBytes = e1
Timer1.Enabled = True
Timer1.Interval = 100
End Sub
Private Sub Timer1_Timer()
Dim EBytes&, SBytes&, CSpeed&
EBytes = ReadBytes("Dial-Up Adapter\BytesRecvd")
SBytes = ReadBytes("Dial-Up Adapter\BytesXmit")
CSpeed = ReadBytes("Dial-Up Adapter\ConnectSpeed")
If EBytes > -1 Then Label1.Caption = EBytes - e1
If SBytes > -1 Then Label2.Caption = SBytes - s1
If SBytes > -1 And EBytes <> e1 Then
Label5.Caption = CSpeed
End If
If LBytes < EBytes Then
Q = (EBytes - LBytes) / (Timer1.Interval / 1000)
CNT = CNT + 1
Else
Q = 0
End If
SUM = SUM + Q
QQ = SUM / CNT
Label6.Caption = "[ " & QQ & " ] " & Q
LBytes = EBytes
End Sub
Private Function ReadBytes(Entry$) As Long
Dim hKey&, L&, X&, DW&
X = RegOpenKeyEx(HKEY_DYN_DATA, "PerfStats\StatData", 0, _
KEY_READ, hKey)
If X <> ERROR_SUCCESS Then Exit Function
X = RegQueryValueEx(hKey, Entry, 0&, DW, ByVal 0&, L)
If X <> ERROR_SUCCESS Then Exit Function
X = RegQueryValueEx(hKey, Entry, 0&, DW, ReadBytes, L)
If X <> ERROR_SUCCESS Then Exit Function
RegCloseKey hKey
End Function
Private Sub Reset()
e1 = ReadBytes("Dial-Up Adapter\BytesRecvd")
s1 = ReadBytes("Dial-Up Adapter\BytesXmit")
SUM = 0
CNT = 1
End Sub

INTERNET BAGLANTI DURUMUNU OGRENMEK

Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir
Option Explicit
Private Declare Function RasEnumConnections Lib "RasApi32.dll" _
Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As _
Long, lpcConnections As Long) As Long
Private Declare Function RasGetConnectStatus Lib "RasApi32.dll" _
Alias "RasGetConnectStatusA" (ByVal hRasCon As Long, _
lpStatus As Any) As Long
Const RAS_MaxEntryName = 256
Const RAS_MaxDeviceType = 16
Const RAS_MaxDeviceName = 32
Private Type RASType
dwSize As Long
hRasCon As Long
szEntryName(RAS_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type
Private Type RASStatusType
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS_MaxDeviceName) As Byte
End Type
Private Sub Form_Load()
Timer1.Interval = 200
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
DFÜStatus
End Sub
Private Function DFÜStatus() As Boolean
Dim RAS(255) As RASType, RASStatus As RASStatusType
Dim lg&, lpcon&, Result&
RAS(0).dwSize = 412
lg = 256 * RAS(0).dwSize
Result = RasEnumConnections(RAS(0), lg, lpcon)
If lpcon = 0 Then
Label1.Caption = "Offline" '###
DFÜStatus = False
Else
RASStatus.dwSize = 160
Result = RasGetConnectStatus(RAS(0).hRasCon, RASStatus)
If RASStatus.RasConnState = &H2000 Then
Label1.Caption = "Online" '###
DFÜStatus = True
Else
Label1.Caption = "Baglanti Kopuk" '###
DFÜStatus = False
End If
End If
End Function

INTERNET BAGLANTISI OLUSTURMAK - KESMEK

Bu kod sayesinde internete bagli olup olmadigimiz ögrenilebilir.
Option Explicit
Const RAS_MaxDeviceType = 16
Const RAS95_MaxDeviceName = 128
Const RAS95_MaxEntryName = 256
Private Type RASENTRYNAME95
dwSize As Long
szEntryName(RAS95_MaxEntryName) As Byte
End Type
Private Type RASCONN95
dwSize As Long
hRasConn As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
Private Declare Function RasEnumConnections Lib "RasApi32.DLL" _
Alias "RasEnumConnectionsA" (lprasconn As Any, lpcb As _
Long, lpcConnections As Long) As Long
Private Declare Function RasEnumEntries Lib "RasApi32.DLL" _
Alias "RasEnumEntriesA" (ByVal reserved$, ByVal _
lpszPhonebook$, lprasentryname As Any, lpcb As Long, _
lpcEntries As Long) As Long
Private Declare Function RasHangUp Lib "RasApi32.DLL" _
Alias "RasHangUpA" (ByVal hRasConn As Long) As Long
Dim DFÜname$, RCon As Long
Private Sub HangUp(ByVal Verbindung$)
Dim s As Long, l As Long, ln As Long, aa$
ReDim r(255) As RASCONN95
r(0).dwSize = 412
s = 256 * r(0).dwSize
l = RasEnumConnections(r(0), s, ln)
For l = 0 To ln - 1
aa = StrConv(r(l).szEntryName(), vbUnicode)
aa = Left$(aa, InStr(aa, Chr$(0)) - 1)
If aa = Verbindung Then
RCon = r(l).hRasConn
Dim rec As Long
rec = RasHangUp(RCon)
End If
Next l
End Sub
Private Sub Command1_Click()
If List1.ListIndex = -1 Then Exit Sub
DFÜname = List1.List(List1.ListIndex)
Shell "rundll32.exe rnaui.dll,RnaDial " & DFÜname
SendKeys "{ENTER}", True
SendKeys "{ENTER}", True
Me.SetFocus
End Sub
Private Sub Command2_Click()
Call HangUp(DFÜname)
End Sub
Private Sub Form_Load()
Dim s As Long, ln As Long, i%, conname$
Dim r(255) As RASENTRYNAME95
r(0).dwSize = 264
s = 256 * r(0).dwSize
Call RasEnumEntries(vbNullString, vbNullString, r(0), s, ln)
For i = 0 To ln - 1
conname = StrConv(r(i).szEntryName(), vbUnicode)
List1.AddItem Left$(conname, InStr(conname, vbNullChar) - 1)
Next i
If List1.ListCount <> 0 Then List1.ListIndex = 0
End Sub

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

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)

alıntıdır