Visual
Basic Source Code
Page: 3
We provide this collection of visual basic
codes to offer our hand to the Visual Basic community and
provide you with codes to enhance your applications and to
have fun with. As we come across new codes, we will add them
to the collection. Without your support however, this
collection can not grow. Please send your Visual Basic Codes
to alpha_productions@hotmail.com and proper credit
will be given.
Contents
Shell
out to default web browser
Close all windows and
logon as a different user
Shut down the computer
Reboot the computer
Find free disk space
on a computer
Detect if
computer has a sound card that plays wave audio
Check for the
existence of a file.
Find and replace one
string with another.
Creating a flashing
form title bar.
Determine if a
computer is connected to the Internet
Change the Windows wallpaper.
Determine whether or
not the screen saver is enabled.
Determine the screen
saver time-out value in seconds
Change the Windows
display resolution.
Associate a file
extension with an application
Determine if a directory exists
Retrieve double-click
time of mouse in milliseconds
Change double-click
time of mouse
Retrieve number of
mouse buttons
Swap the left and
right mouse buttons
Shell out to
default web browser
Submitted By: Alpha Programming
'used for
shelling out to the default web browser
Declare Function ShellExecute Lib "shell32.dll" Alias
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation
As String, ByVal lpFile As String, ByVal lpParameters As String,
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Const conSwNormal = 1
ShellExecute hwnd, "open",
"http://www.vbcode.com", vbNullString, vbNullString,
conSwNo
Contents | Home | Contact Us
Close all windows
and logon as a different user
Submitted By: Alpha Programming
Private
Const EWX_LogOff As Long = 0
Private Declare Function ExitWindowsEx Lib "user32"
(ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
'close all programs and log on as a different user
lngResult = ExitWindowsEx(EWX_LogOff,
Contents | Home | Contact Us
Shut down the
computer
Submitted By: Alpha Programming
Private
Const EWX_SHUTDOWN As Long = 1
Private Declare Function ExitWindowsEx Lib "user32"
(ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
'shut down the computer
lngResult = ExitWindowsEx(EWX_SHUTDOWN,
Contents | Home | Contact Us
Reboot the
computer
Submitted By: Alpha Programming
Private
Const EWX_REBOOT As Long = 2
Private Declare Function ExitWindowsEx Lib "user32"
(ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
'reboot the computer
lngResult = ExitWindowsEx(EWX_REBOOT,
Contents | Home | Contact Us
Find free disk
space on a computer
Submitted By: Alpha Programming
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
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")
Contents | Home | Contact Us
Detect if computer
has a sound card that plays wave audio
Submitted
By: Alpha Programming
Private
Declare Function waveOutGetNumDevs Lib "winmm" () As
Long
Dim i As Long
i = waveOutGetNumDevs()
If i > 0 Then ' There is at least one device.
MsgBox "You Can Play Wave Data"
Else
MsgBox "Cannot Play Wave Data"
Contents | Home | Contact Us
Check for the
existence of a file.
Submitted By: Alpha Programming
Public
Function FileExists(strPath As String) As Integer
FileExists = Not (Dir(strPath) = "")
End Func
Contents | Home | Contact Us
Find and replace
one string with another.
Submitted By: Alpha Programming
Function
FindReplace(SourceString, SearchString, ReplaceString)
tmpString1 = SourceString
Do Until vFixed
tmpString2 = tmpString1
tmpString1 = ReplaceFirstInstance(tmpString1,
SearchString,ReplaceString)
If tmpString1 = tmpString2 Then vFixed = True
Loop
FindReplace = tmpString1
End Function
Function ReplaceFirstInstance(SourceString, SearchString,
ReplaceString)
FoundLoc = InStr(1, SourceString, SearchString)
If FoundLoc <> 0 Then
ReplaceFirstInstance = Left(SourceString, FoundLoc - 1) & _
ReplaceString & Right(SourceString, _
Len(SourceString) - (FoundLoc - 1) - Len(SearchString))
Else
ReplaceFirstInstance = SourceString End If
Contents | Home | Contact Us
Creating a
flashing form title bar.
Submitted By: Alpha Programming
Private
Declare Function FlashWindow Lib "user32" (ByVal hWnd
As Long, ByVal bInvert As Long) As Long
Dim lngReturnValue As Long
lngReturnValue = FlashWindow(Form1.hWnd, Tr
Contents | Home | Contact Us
Determine if a
computer is connected to the Internet
Submitted
By: Alpha Programming
Public
Declare Function RasEnumConnections Lib "RasApi32.dll"
Alias "RasEnumConnectionsA" (lpRasCon As Any, lpcb As
Long, lpcConnections As Long) As Long
Public Declare Function RasGetConnectStatus Lib
"RasApi32.dll" Alias "RasGetConnectStatusA"
(ByVal hRasCon As Long, lpStatus As Any) As Long
'
Public Const RAS95_MaxEntryName = 256
Public Const RAS95_MaxDeviceType = 16
Public Const RAS95_MaxDeviceName = 32
'
Public Type RASCONN95
dwSize As Long
hRasCon As Long
szEntryName(RAS95_MaxEntryName) As Byte
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'
Public Type RASCONNSTATUS95
dwSize As Long
RasConnState As Long
dwError As Long
szDeviceType(RAS95_MaxDeviceType) As Byte
szDeviceName(RAS95_MaxDeviceName) As Byte
End Type
'A call to the function IsConnected returns true if the computer
has established a connection to the internet.
Public Function IsConnected() As Boolean
Dim TRasCon(255) As RASCONN95
Dim lg As Long
Dim lpcon As Long
Dim RetVal As Long
Dim Tstatus As RASCONNSTATUS95
'
TRasCon(0).dwSize = 412
lg = 256 * TRasCon(0).dwSize
'
RetVal = RasEnumConnections(TRasCon(0), lg, lpcon)
If RetVal <> 0 Then
MsgBox "ERROR"
Exit Function
End If
'
Tstatus.dwSize = 160
RetVal = RasGetConnectStatus(TRasCon(0).hRasCon, Tstatus)
If Tstatus.RasConnState = &H2000 Then IsConnected = True Else
IsConnected = False
Contents | Home | Contact Us
Change the Windows
wallpaper.
Submitted By: Alpha Programming
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
Dim lngSuccess As Long
Dim strBitmapImage As String
strBitmapImage = "c:\windows\straw.bmp"
lngSuccess = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0,
strBitmapIma
Contents | Home | Contact Us
Determine whether
or not the screen saver is enabled.
Submitted
By: Alpha Programming
Public
Const SPI_GETSCREENSAVEACTIVE = 16
Declare Function SystemParametersInfo Lib "user32"
Alias "SystemParametersInfoA" (ByVal uAction As Long,
ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As
Long
Dim blnReturn As Boolean
Dim blnActive As Boolean
' Determine whether screen saver is enabled.
Call SystemParametersInfo(SPI_GETSCREENSAVEACTIVE, vbNull,
blnReturn, 0) blnActive = bl
Contents | Home | Contact Us
Determine the
screen saver time-out value in seconds
Submitted
By: Alpha Programming
Public
Const SPI_GETSCREENSAVETIMEOUT = 14
Declare Function SystemParametersInfo Lib "user32"
Alias "SystemParametersInfoA" (ByVal uAction As Long,
ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As
Long
Dim intValue As Integer
'Get the screen saver time-out value in seconds.
Call SystemParametersInfo(SPI_GETSCREENSAVETIMEOUT, vbNull,
intValue, 0)
MsgBox ("Screen saver time-out value: " & intValue
& " sec
Contents | Home | Contact Us
Change the Windows
display resolution.
Submitted By: Alpha Programming
Public
Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1
Type typDevMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Declare Function EnumDisplaySettings Lib "user32" Alias
"EnumDisplaySettingsA" (ByVal lpszDeviceName As Long,
ByVal iModeNum As Long, lptypDevMode As Any) As Boolean
Declare Function ChangeDisplaySettings Lib "user32"
Alias "ChangeDisplaySettingsA" (lptypDevMode As Any,
ByVal dwFlags As Long) As Long
Declare Function ExitWindowsEx Lib "user32" (ByVal
uFlags As Long, ByVal dwReserved As Long) As Long
Dim typDevM As typDevMODE
Dim lngResult As Long
Dim intAns As Integer
' Retrieve info about the current graphics mode
' on the current display device.
lngResult = EnumDisplaySettings(0, 0, typDevM)
' Set the new resolution. Don't change the color
' depth so a restart is not necessary.
With typDevM
.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
.dmPelsWidth = 640 'ScreenWidth (640,800,1024, etc)
.dmPelsHeight = 480 'ScreenHeight (480,600,768, etc)
End With
' Change the display settings to the specified graphics mode.
lngResult = ChangeDisplaySettings(typDevM, CDS_TEST)
Select Case lngResult
Case DISP_CHANGE_RESTART
intAns = MsgBox("You must restart your computer to apply
these changes." & _
vbCrLf & vbCrLf & "Do you want to restart
now?", _
vbYesNo + vbSystemModal, "Screen Resolution")
If intAns = vbYes Then Call ExitWindowsEx(EWX_REBOOT, 0) Case
DISP_CHANGE_SUCCESSFUL Call ChangeDisplaySettings(typDevM,
CDS_UPDATEREGISTRY) MsgBox "Screen resolution changed",
vbInformation, "Resolution Changed" Case Else
Contents | Home | Contact Us
Associate a file
extension with an application
Submitted By: Alpha Programming
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
Dim sKeyName As String 'Holds Key Name in registry.
Dim sKeyValue As String 'Holds Key Value in registry.
Dim ret& 'Holds error status if any from API calls.
Dim lphKey& 'Holds created key handle from RegCreateKey.
'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\comm
Contents | Home | Contact Us
Determine if a
directory exists
Submitted By: Alpha Programming
'-----------------------------------------------------------
' FUNCTION: DirExists
'
' Determines whether the specified directory name exists.
' This function is used (for example) to determine whether
' an installation floppy is in the drive by passing in
' something like 'A:\'.
'
' IN: [strDirName] - name of directory to check for
'
' Returns: True if the directory exists, False otherwise
'-----------------------------------------------------------
'
Public Function DirExists(ByVal strDirName As String) As Integer
Dim strDummy As String
On Error Resume Next
If Right$(strDirName, 1) <> "\" Then
strDirName = strDirName & "\"
End If
strDummy = Dir$(strDirName & "*.*", vbDirectory)
DirExists = Not (strDummy = vbNullString)
Contents | Home | Contact Us
Retrieve
double-click time of mouse in milliseconds
Submitted
By: Alpha Programming
Declare
Function GetDoubleClickTime& Lib "user32" ()
'retrieve the mouse double-click time in milliseconds
Dim lngReturn As Long
lngReturn = GetDoubleClickTi
Contents | Home | Contact Us
Change
double-click time of mouse
Submitted By: Alpha Programming
Declare
Function SetDoubleClickTime Lib "user32" Alias
"SetDoubleClickTime" (ByVal wCount As Long) As Long
'set double-click time in milliseconds
setDoubleClickTime(50
Contents | Home | Contact Us
Retrieve number of
mouse buttons
Submitted By: Alpha Programming
Declare
Function GetSystemMetrics Lib "user32" (ByVal nIndex As
Long) As Long
Dim lngReturn
lngReturn = GetSystemMetrics(SM_CMOUSEBUTTO
Contents | Home | Contact Us
Swap the left and
right mouse buttons
Submitted By: Alpha Programming
Private
Declare Function SwapMouseButton& Lib "user32"
(ByVal bSwap As Long)
'swap Left and Right mouse buttons
SwapMouseButton (True)
'set mouse buttons back to normal
SwapMouseButton (
Contents | Home | Contact Us
Home | Links | Link
to Us | Contact Us
Copyright©2001
Alpha Productions. All rights reserved.