Site hosted by Angelfire.com: Build your free website today!
VB3Codes

Back To Main Page

Name Code
Stay On Top Module:

Public Declare Sub SetWindowPos Lib "user32" (ByVal hWnd As Integer, ByVal hWndInsertAfter As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal cx As Integer, ByVal cy As Integer, ByVal wFlags As Integer)

Form Load:

Call SetWindowPos(hWnd, -1, 0, 0, 0, 0, &H2 Or &H1)

Center Form Module:

Sub CenterForm (Frm As Form)
Form1.Top = (Screen.Height * .85) / 2 - Form1.Height / 2
Form1.Left = Screen.Width / 2 - Form1.Width / 2
End Sub

Form Load:

centerform me

Disable Ctrl + Alt + Delete Module:

Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fu WinIni As Long) As Long

Sub DisableCtrlAltDelete(bDisabled As Boolean)
Dim X As Long
X = SystemParametersInfo(97, bDisabled, CStr(1),0)
End Sub

Put this code where you want to activate the Sub:
Call DisableCtrlAltDelete(True)

To let the user use Ctrl+Alt+Delete use this code:
Call DisableCtrlAltDelete(False)

Drag a form with your Mouse Module:

Declare Function ReleaseCapture Lib "user32" () As Long
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN=&HAl

Form_MouseDown:

ReleaseCapture
SendMessage hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&

Open/Close the Cd-Rom Drive Module:

DeclareFunction mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand as string, ByVal lpstrReturnString as string, ByVal hwndCallback as long) As Long

To Close the Cd-Rom use this code:
retvalue = mciSendString("set CD Audio door closed", returnstring, 127, 0)

To Open the Cd-Rom use this code:
retvalue = mciSendString("set CD Audio door open", returnstring, 127, 0)

Flash Bar Module:

Declare Function FlashWindow Lib "user32" (ByVal hwnd As Long, ByVal bInvert As Long) As Long

Timer:

timer1.interval = 600
Call FlashWindow(Me.hwnd, True)

Fade Form Blue Form Load:

Form1.show
Dim X
Dim y
Dim red
Dim green
Dim blue
X = form1.Width
y = form1.Height
red = 255
green = 255
blue = 255
Do Until red = 0
y = y - form1.Height / 255 * 1
red = red - 1
form1.Line (0, 0)-(X, y), RGB(0, 0, red), BF
Loop

See how long windows has been running Module:

Declare Function GetTickCount& Lib "kernel32" ()

Command Button:

Dim lngReturn As Long
lngReturn = GetTickCount()
MsgBox ("Windows has been running for " & (lngReturn / 1000) & " seconds.")

Rename A File Command Button:

Name "Path to file" As "Path you want renamed file to be"

Send Text to ClipBoard Command Button:

Clipboard.SetText Text1.text

Delate A File Command Button:

Kill("Path to file goes here")

Open A File Using Default Program Command Button:

Shell( "Path to file goes here")

Rename A File Command Button:

Name "Path to file" As "Path you want renamed file to be"

Get Size of a file Command Button:

kilo = FileLen("Path of File goes here") / 1000
Text1.Text = kilo

Min All open windows Module:

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const KEYEVENTF_KEYUP = &H2
Const VK_LWIN = &H5B

Command Button:

' 77 is the character code for the letter 'M'
Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(77, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)

3D Tunel Form:

Form1.Show
Form1.Scale (0, 100)-(100, 0)
Form1.BackColor = vbBlack
Form1.ForeColor = vbBlack
For X% = 0 To 100
Form1.ForeColor = RGB(90, 90, 90)
Form1.Line (X%, 0)-(100 - X%, 100)
Form1.ForeColor = RGB(r%, g%, b%)
Form1.Line (0, X%)-(100, 100 - X%)
current = Timer
Do: DoEvents
Loop Until Timer - current > 1E-99
Next X%
For X% = 10 To 50
Me.Line (50 - X%, 50 + X%)-(50 + X%, 50 - X%), , BF
current = Timer
Do: DoEvents
Loop Until Timer - current > 1E-99
Next X%

Center Form at top of Screen Form:

With form1
.Left = (Screen.Width - .Width) / 2
.Top = (Screen.Height - .Height) / (Screen.Height)
End With

Alot of lines Command Button:

If Form1.WindowState = vbMinimized Then Exit Sub
Form1.BackColor = vbBlack
Form1.ScaleHeight = 100
Form1.ScaleWidth = 100
For x = 0 To 300
DoEvents
X1 = Int(Rnd * 101)
X2 = Int(Rnd * 101)
Y1 = Int(Rnd * 101)
Y2 = Int(Rnd * 101)
colo = Int(Rnd * 15)
Form1.Line (X1, Y1)-(X2, Y2), QBColor(colo)
Form1.Line (X1, Y2)-(X2, Y1), QBColor(colo)
Form1.Line (X2, Y1)-(X1, Y2), QBColor(colo)
Form1.Line (Y1, Y2)-(X1, X2), QBColor(colo)
Next x

Lag Text Command Button:

Dim X As Integer
Dim current As Variant
Dim Y As String
Y = Form1.Label1.Caption
Form1.Label1.Caption = ""
Form1.Show
For X = 0 To Len(Y)
If X = 0 Then
Form1.Label1.Caption = ""
current = Timer
Do While Timer - current < 0.1
DoEvents
Loop
GoTo done
Else: End If
Form1.Label1.Caption = Left(Y, X)
current = Timer
Do While Timer - current < 0.05
DoEvents
Loop
done:
Next X

Shut down the Computer Module:
Private Const EWX_SHUTDOWN As Long = 1
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

Code:

lngResult = ExitWindowsEx(EWX_SHUTDOWN, 0&)

Reboot the Computer Module:

Private Const EWX_REBOOT As Long = 2
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long

Code:

lngResult = ExitWindowsEx(EWX_REBOOT, 0&)

Find free Disk Space on a Computer Module:

Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, lpSectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTtoalNumberOfClusters As Long) As Long

Public Type DiskInformation
lpSectorsPerCluster As Long
lpBytesPerSector As Long
lpNumberOfFreeClusters As Long
lpTotalNumberOfClusters As Long
End Type

Code:

Dim info As DiskInformation
Dim lAnswer As Long
Dim lpRootPathName As String
Dim lpSectorsPerCluster As Long
Dim lpBytesPerSector As Long
Dim lpNumberOfFreeClusters As Long
Dim lpTotalNumberOfClusters As Long
Dim lBytesPerCluster As Long
Dim lNumFreeBytes As Double
Dim sString As String

lpRootPathName = "c:\"
lAnswer = GetDiskFreeSpace(lpRootPathName, lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters)
lBytesPerCluster = lpSectorsPerCluster * lpBytesPerSector
lNumFreeBytes = lBytesPerCluster * lpNumberOfFreeClusters
sString = "Number of Free Bytes : " & lNumFreeBytes & vbCr & vbLf
sString = sString & "Number of Free Kilobytes: " & (lNumFreeBytes / 1024) & "K" & vbCr & vbLf
sString = sString & "Number of Free Megabytes: " & Format(((lNumFreeBytes / 1024) / 1024), "0.00") & "MB"
MsgBox sString

Check for existance of a file Code:

Public Function FileExists(strPath As String) As Integer

FileExists = Not (Dir(strPath) = "")

End Function

Change the Windows Wallpager Module:

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
Public Const SPI_SETDESKWALLPAPER = 20

Code:

Dim lngSuccess As Long
Dim strBitmapImage As String

strBitmapImage = "c:\windows\straw.bmp"
lngSuccess = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, strBitmapImage, 0)

Move File to the Recycle Bin Module:

Private Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As Long
End Type

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long

Private Const FO_DELETE = &H3
Private Const FOF_ALLOWUNDO = &H40

Code:

Dim typOperation As SHFILEOPSTRUCT
With typOperation
.wFunc = FO_DELETE
.pFrom = "filename.txt" 'File to move to bin
.fFlags = FOF_ALLOWUNDO
End With
SHFileOperation typOperation

Retrieve Windows User Name Module:

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Code:

Sub Get_User_Name()
Dim lpBuff As String * 25
Dim ret As Long, UserName As String
ret = GetUserName(lpBuff, 25)
UserName = Left(lpBuff, InStr(lpBuff, Chr(0)) - 1)
MsgBox UserName
End Sub

Retrieve the Computer Name Module:

Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Codes:

Dim strBuffer As String
Dim lngBufSize As Long
Dim lngStatus As Long
lngBufSize = 255
strBuffer = String$(lngBufSize, " ")
lngStatus = GetComputerName(strBuffer, lngBufSize)
If lngStatus <> 0 Then
MsgBox ("Computer name is: " & Left(strBuffer, lngBufSize))
End If

Associate a File Extension with an Application Module:

Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValue Lib "advapi32.dll" Alias "RegSetValueA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
' Return codes from Registration functions.
Const ERROR_SUCCESS = 0&
Const ERROR_BADDB = 1&
Const ERROR_BADKEY = 2&
Const ERROR_CANTOPEN = 3&
Const ERROR_CANTREAD = 4&
Const ERROR_CANTWRITE = 5&
Const ERROR_OUTOFMEMORY = 6&
Const ERROR_INVALID_PARAMETER = 7&
Const ERROR_ACCESS_DENIED = 8&
Private Const HKEY_CLASSES_ROOT = &H80000000
Private Const MAX_PATH = 260&
Private Const REG_SZ = 1

Code:

Dim sKeyName As String
Dim sKeyValue As String
Dim ret&
Dim lphKey&

'This creates a Root entry called "MyApp".
sKeyName = "MyApp"
sKeyValue = "My Application"
ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
'This creates a Root entry called .BAR associated with "MyApp".
sKeyName = ".BAR"
sKeyValue = "MyApp"
ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
ret& = RegSetValue&(lphKey&, "", REG_SZ, sKeyValue, 0&)
'This sets the command line for "MyApp".
sKeyName = "MyApp"
sKeyValue = "c:\mydir\my.exe %1"
ret& = RegCreateKey&(HKEY_CLASSES_ROOT, sKeyName, lphKey&)
ret& = RegSetValue&(lphKey&, "shell\open\command", REG_SZ, sKeyValue, MAX_PATH)

Swap Left and Right Mouse Buttons Module:

Private Declare Function SwapMouseButton& Lib "user32" (ByVal bSwap As Long)

Code:

'swap Left and Right mouse buttons
SwapMouseButton (True)

'set mouse buttons back to normal
SwapMouseButton (False)

Hide Mouse from User Module:

Declare Function ShowCursor& Lib "user32"(ByVal bShow As Long)

Code:

'To hide the cursor, use this:
ShowCursor (False)

'To show the cursor, use this:
ShowCursor (True)

Keep Mouse Pointer Inside of a Form Module:

Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Declare Function ClipCursor Lib "user32" (lpRect As Any) As Long

Code:

'The form should not be set to sizable or this will not work. You should also call the code each time the user moves the form.
Dim lngX As Long
Dim lngY As Long
Dim lngReturn As Long
Dim NewRect As RECT

'Get the screens Twips per pixel (form's scalemode must be Twips)
lngX = Screen.TwipsPerPixelX
lngY = Screen.TwipsPerPixelY
'Set cursor region to that of form With NewRect
.Left = Me.Left / lngX
.Top = Me.Top / lngY
.Right = .Left + Me.Width / lngX
.Bottom = .Top + Me.Height / lngY
End With
lngReturn = ClipCursor(NewRect)

Back To Main Page

To Submit VB5 Codes Send Mail To:

mailto:LooT
mailto:DusTy