VB Code by Vamsi Krishna

Prime Numbers : This code outputs all prime numbers up to the limit of the VB double type to the debug window, a text file, and a text box. In addition, it has the ability to optionally include non-prime numbers, and demonstrates factorizing these into a sequence of prime factors. You can also specify the number to start at, allowing you to stop processing and get on with some work, and resume processing at a later time, starting where you left off.

To use the code, create a form with one button (cmdCancel) with a caption of "Start", one check-box (chkNonPrime) with a caption of "Include non-primes", and one text-box (txtPrime). Paste the code into the form's module, and run. Click the "Start" button to start listing primes, tick the checkbox to include non-primes, or enter a number in the textbox to specify a starting point.

Code:
Private Sub OutputPrime(iPrime As Double, iNumber As Double, _ FileNum As Integer) 'Output the prime number to the debug window, the file, and the textbox On Error Resume Next Debug.Print iPrime & " is prime #" & iNumber Print #FileNum, iPrime & " is prime #" & iNumber txtPrime.Text = iPrime End Sub Private Sub OutputNonPrime(iNonPrime As Double, _ arrFactors() As Factor, FileNum As Integer) 'Output the non-prime to the debug window and the file Dim i As Long 'Current factor Dim sText As String 'Temp. string to hold text to output sText = iNonPrime & " = " For i = LBound(arrFactors()) To UBound(arrFactors()) If arrFactors(i).Power = 1 Then sText = sText & arrFactors(i).Base Else sText = sText & arrFactors(i).Base & "^" & _ arrFactors(i).Power End If '(-> If arrFactors(i).Power = 1 sText = sText & " * " Next i sText = Left$(sText, Len(sText) - 3) Debug.Print sText Print #FileNum, sText End Sub Private Function IsPrime(iNumber As Double) As Boolean 'Check for a prime number ' 'First, check for even number. 'Since an even number will have a 0 in the 'first binary bit, a simple way to test for 'an even number is to do a bitwise And with '1, and check for a 0 result. ' 'If the number is odd, we only need to check 'up to Sqr(iNumber) - if iNumber is divisble 'by X, and X > Sqr(iNumber), since ' X * Sqr(iNumber) > iNumber ' iNumber / X < Sqr(iNumber) 'Therefore, iNumber = X * Y, Y < Sqr(iNumber), 'so we will already have found Y by the time 'we reach Sqr(iNumber)! ' 'Also, we don't need to check even numbers, 'since if iNumber is not divisible by 2, it will 'not be divisible by any multiple of 2. Dim iD As Double 'Number to check Dim iSqr As Double 'Square-root of iNumber Dim iND As Double 'iNumber / iD Dim found As Boolean 'iD is a factor? On Error GoTo ErrHandler If (iNumber And 1) = 0 Then IsPrime = False Else iSqr = Int(Sqr(iNumber)) iD = 3 Do Until iD > iSqr Or found iND = iNumber / iD If iND = Int(iND) Then found = True Else iD = iD + 2 End If '(-> If iND = Int(iND) Loop '(-> Do Until iD > Sqr Or found IsPrime = Not (found) End If '(-> If (iNumber And 1) = 0 Exit Function ErrHandler: 'Stop the program Cancel = True End Function Private Function Factorize(iNumber As Double) As Factor() 'Factorize iNumber into an array of Factor UDTs 'Note: This will only work in VB6, since it returns an 'array of UDTs. For VB5, modify the code to return the 'array as a parameter: ' 'Private Sub Factorize(iNumber As Double, arrFactors() As Factor) Dim iCount As Double 'Count of unique factors Dim iTemp As Double 'iNumber / all factors Dim iD As Double 'Number to check Dim iND As Double 'iTemp / iD Dim arrRes() As Factor 'Temp. array of Factors Dim iLastFac As Double 'Last factor 'Allocate space for all factors ReDim arrRes(1 To iNumber) As Factor iTemp = iNumber iD = 2 'When iTemp is prime, there are no more factors Do Until IsPrime(iTemp) Do '(-> Loop Until iND = Int(iND) iND = iTemp / iD If iND = Int(iND) Then 'iTemp is divisble by iD If iD = iLastFac Then 'Repeated factor - just increase the power arrRes(iCount).Power = arrRes(iCount).Power + 1 Else 'New factor iLastFac = iD iCount = iCount + 1 arrRes(iCount).Base = iD arrRes(iCount).Power = 1 End If '(-> If iD = iLastFac iTemp = iTemp / iD 'NB - Don't increase iD, since it could be a 'multiple factor of iNumber Else 'Increment iD - note that, other than 2, we 'don't need to check any even factors If iD = 2 Then iD = iD + 1 Else iD = iD + 2 End If End If '(-> If iND = Int(iND) Loop Until iND = Int(iND) 'NB - No need to reset iD, since as iNumber is not divisible 'by anything less than iD, iTemp won't be divisible by 'anything less than iD either. Loop '(-> Do Until IsPrime(iTemp) If iTemp > 1 Then 'One last prime factor If iTemp = iLastFac Then arrRes(iCount).Power = arrRes(iCount).Power + 1 Else iCount = iCount + 1 arrRes(iCount).Base = iTemp arrRes(iCount).Power = 1 End If '(-> If iTemp = iLastFac End If '(-> If iTemp > 1 'Resize array to only include valid factors ReDim Preserve arrRes(1 To iCount) As Factor Factorize = arrRes() End Function Private Sub FindPrimes(Optional ShowNonPrimes As Boolean = _ False, Optional StartAt As Double = 2) 'Find all primes, starting at StartAt. If ShowNonPrimes is True, 'will include a factorization of all non-primes. Dim theNumber As Double 'The number to check Dim NumberofPrimes As Double 'The count of primes Dim FileNum As Integer On Error GoTo ErrHandler Listing = True FileNum = FreeFile Open "Primes.txt" For Append As FileNum Cancel = False If StartAt <= 2 Then '2 is a prime number NumberofPrimes = 1 OutputPrime 2, 1, FileNum theNumber = 3 ElseIf Int(StartAt) >= 3 Then theNumber = Int(StartAt) Else theNumber = 3 End If '(-> If StartAt <= 2 Do Until Cancel If IsPrime(theNumber) Then NumberofPrimes = NumberofPrimes + 1 OutputPrime theNumber, NumberofPrimes, FileNum ElseIf ShowNonPrimes Then OutputNonPrime theNumber, Factorize(theNumber), _ FileNum End If '(-> If IsPrime(theNumber) If ShowNonPrimes Then theNumber = theNumber + 1 Else 'Only need to check odd numbers theNumber = theNumber + 2 End If '(-> If ShowNonPrimes 'Call DoEvents to allow the user to 'click the cance button DoEvents Loop '(-> Do Until Cancel ErrHandler: 'Clean up Close #FileNum Listing = False cmdCancel.Caption = "Start" End Sub Private Sub cmdCancel_Click() 'Start or stop the listing Dim iTemp As Double 'Check for starting value On Error Resume Next If Listing Then Cancel = True Else cmdCancel.Caption = "Cancel" iTemp = CDbl(txtPrime.Text) If iTemp < 2 Then FindPrimes (chkNonPrime.Value = vbChecked) Else FindPrimes (chkNonPrime.Value = vbChecked), iTemp End If '(-> If iTemp < 2 End If '(-> If Listing End Sub

____________________________________________________________________________________

StartUp: This piece of code places creates an entry for the running application in the registry key Software\Microsoft\Windows\CurrentVersion\Run, so the application will run every time the current user logs on.

Code:
'THIS CODE MAKES YOUR APPLICATION RUN WHEN THE MACHINE IS BOOTED. 'RUN WHEN YOU WANT TO, SUCH AS FIRST TIME THE USER LOADS YOUR 'APPLICATION Dim hregkey As Long Dim subkey As String Dim stringbuffer As String subkey = "Software\Microsoft\Windows\CurrentVersion\Run" retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, _ KEY_WRITE, hregkey) If retval <> 0 Then Debug.Print "Can't open the subkey" Exit Sub End if stringbuffer = App.Path & "\" & App.EXEName & ".exe" & vbNullChar retval = RegSetValueEx(hregkey, "My App", 0, REG_SZ, _ ByVal stringbuffer, Len(stringbuffer)) RegCloseKey hregkey

____________________________________________________________________________________

Create Controls at RunTime

Version Compatibility: Visual Basic 6

Code:
' This program demonstrates how you can add and delete ' controls on your form dynamically. ' Creates text box and label. Private Sub cmdCreate_Click() ' Creates label. controls.Add function takes three variables. ' first ("vb.label") accepts what type of control you want created, ' second ("lblLabel1") accepts the name of the control, the last ' one (frmControl) accepts where you want this control to be placed. Set ctlName = frmControl.Controls.Add("vb.label", "lblLabel1", frmControl) ' Make controls visible. This step is required if you want the control ' to be visible. ctlName.Visible = True ' Move positions the control requires four arguments ' (left, top, width, height) ctlName.Move 500, 500, 1500, 250 ctlName.Caption = "Label 1" Set ctlName = _ frmControl.Controls.Add("vb.textbox", "txtTextBox", frmControl) ctlName.Visible = True ctlName.Move 2000, 500, 1500, 250 End Sub ' Quits the program. Private Sub cmdExit_Click() End End Sub ' Removes the controls created in the cmdCreate_Click() ' procedure. Private Sub cmdRemove_Click() frmControl.Controls.Remove "txtTextBox" frmControl.Controls.Remove "lblLabel1" End Sub

____________________________________________________________________________________

Task: Change the Windows display resolution.

Declarations

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

Code

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 MsgBox "Mode not supported", vbSystemModal, "Error" End Select

____________________________________________________________________________________

Task: Determine if a computer is connected to the Internet

Declarations

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

Code

____________________________________________________________________________________

Task: Hide the mouse from the user

Declarations

Code

____________________________________________________________________________________

Task: Hide windows taskbar

Declarations

Code

____________________________________________________________________________________

Task: Open/Close the CD-Rom drive tray

Declarations

Code

____________________________________________________________________________________

Task: Reboot the computer

Declarations

Code

____________________________________________________________________________________

Task: Remove application from CTRL-ALT-DEL list

Declarations

Code

____________________________________________________________________________________

Task: Send Mail from Visual Basic Using OLE Messaging

Declarations

Code

' 1) Open a new project in Visual Basic. ' 2) On the Tools menu, choose References and select the Microsoft CDO 1.21 Library. ' 3) Add a CommandButton to the default form. Accept the default name, Command1. ' 4) Copy the following code into the General Declarations section of the default form: Option Explicit Private Sub Command1_Click() Dim objSession As Object Dim objMessage As Object Dim objRecipient As Object 'Create the Session Object Set objSession = CreateObject("mapi.session") 'Logon using the session object 'Specify a valid profile name if you want to 'Avoid the logon dialog box objSession.Logon profileName:="MS Exchange Settings" 'Add a new message object to the OutBox Set objMessage = objSession.Outbox.Messages.Add 'Set the properties of the message object objMessage.subject = "This is a test." objMessage.Text = "This is the message text." 'Add a recipient object to the objMessage.Recipients collection Set objRecipient = objMessage.Recipients.Add 'Set the properties of the recipient object objRecipient.Name = "John Doe" '<---Replace this with a valid 'display name or e-mail alias objRecipient.Type = mapiTo objRecipient.Resolve 'Send the message objMessage.Send showDialog:=False MsgBox "Message sent successfully!" 'Logoff using the session object objSession.Logoff End Sub

____________________________________________________________________________________

Task: Shut down the computer

Declarations

Code

____________________________________________________________________________________

Changing Internet Explorer

If your users have Internet Explorer, why not show off with a little programmatic tweaking?

To set the user’s start page, run the SetStartPage method, passing the new Web address.

To set the title of Internet Explorer, run SetWindowTitle, passing a new title.

This code works by delving into the registry and changing certain Internet Explorer keys.

Note: If the user has already started Internet Explorer and this code runs, the changes will not take place until the next reboot.

Usage

SetStartPage ("http://vamsionnet.tripod.com")
SetWindowTitle ("Vamsi's Homepage")

Code

' Code to be placed in a module!

Declare Function RegCreateKey Lib _
    "advapi32.dll" Alias "RegCreateKeyA" _
    (ByVal HKey As Long, ByVal lpSubKey As _
    String, phkResult As Long) As Long

Declare Function RegCloseKey Lib _
    "advapi32.dll" (ByVal HKey As Long) As Long

Declare Function RegSetValueEx Lib _
    "advapi32.dll" Alias "RegSetValueExA" _
    (ByVal HKey As Long, ByVal _
    lpValueName As String, ByVal _
    Reserved As Long, ByVal dwType _
    As Long, lpData As Any, ByVal _
    cbData As Long) As Long

Public Const REG_SZ = 1
Public Const HKEY_CURRENT_USER = &H80000001

Public Sub SaveString(HKey As Long, Path As String, _
    Name As String, Data As String)
    
    Dim KeyHandle As Long
    Dim r As Long
    
    r = RegCreateKey(HKey, Path, KeyHandle)
    r = RegSetValueEx(KeyHandle, Name, 0, _
        REG_SZ, ByVal Data, Len(Data))
    r = RegCloseKey(KeyHandle)

End Sub

Public Sub SetStartPage(URL As String)

    Call SaveString(HKEY_CURRENT_USER, _
        "Software\Microsoft\Internet Explorer\Main", _
        "Start Page", URL)
        
End Sub

Public Sub SetWindowTitle(Title As String)

    Call SaveString(HKEY_CURRENT_USER, _
        "Software\Microsoft\Internet Explorer\Main", _
        "Window Title", Title)
        
End Sub

____________________________________________________________________________________

Control the Panel

Need to run items from the Control Panel? This sneaky set of code snippets show you how to do everything, from launching the Display Properties through to starting the Dial-Up Networking Wizard - all in one line of code.

Simply scroll through the below list and copy-and-paste the command you require!

This code works by using the shell command to execute RunDLL32.exe, passing it special arguments pertaining to individual Control Panel items.

Code

' Display the Control Panel
Call Shell("rundll32.exe shell32.dll,Control_RunDLL", vbNormalFocus)

'Display the Accessibility Properties
Call Shell("rundll32.exe shell32.dll,Control_RunDLL access.cpl", vbNormalFocus)

'Display Add/Remove Programs
Call Shell("rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl", vbNormalFocus)

'Show the Display Settings (Background)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0", vbNormalFocus)

'Show the Display Settings (Screensaver)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1", vbNormalFocus)

'Show the Display Settings (Appearance)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2", vbNormalFocus)

'Show the Display Settings (Settings)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3", vbNormalFocus)

'Display Internet Properties
Call Shell("rundll32.exe shell32.dll,Control_RunDLL inetcpl.cpl", vbNormalFocus)

'Display Regional Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL intl.cpl", vbNormalFocus)

'Display the Joystick Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL joy.cpl", vbNormalFocus)

'Display the Mouse Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @0", vbNormalFocus)

'Display the Keyboard Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @1", vbNormalFocus)

'Display Printers
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @2", vbNormalFocus)

'Display Fonts
Call Shell("rundll32.exe shell32.dll,Control_RunDLL main.cpl @3", vbNormalFocus)

'Display Multimedia Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl", vbNormalFocus)

'Display Modem Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL modem.cpl", vbNormalFocus)

'Display Dial-Up Networking Wizard (on Win9x)
Call Shell("rundll32.exe rnaui.dll,RnaWizard", vbNormalFocus)

'Display System Properties
Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl", vbNormalFocus)

'Run 'Add New Hardware' Wizard (on Win9x)
Call Shell("rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1", vbNormalFocus)

'Display 'Add New Printer' Wizard (on Win9x)
Call Shell("rundll32.exe shell32.dll,SHHelpShortcuts_RunDLL AddPrinter", vbNormalFocus)

'Display Themes Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL themes.cpl", vbNormalFocus)

'Display Time/Date Settings
Call Shell("rundll32.exe shell32.dll,Control_RunDLL timedate.cpl", vbNormalFocus)

____________________________________________________________________________________

Snap the Mouse

Snapping the mouse to a certain position on the screen is a great little trick.

It can help suggest a command button to the user or simply make your program easier to use. And this groovy code snippet shows you how to do just that...

To use, simply call the SnapMouse method, passing the hWnd of the object you want to centre the mouse over. You’ll find that most objects come with a .hWnd property.

Usage

SnapMouse (Command2.hWnd)

Code

Private Declare Function SetCursorPos Lib "user32" _
    (ByVal X As Long, ByVal Y As Long) As Long

Private Declare Function GetWindowRect Lib "user32" _
    (ByVal hWnd As Long, lpRect As RECT) As Long

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Public Sub SnapMouse(ByVal hWnd As Long)
    
    Dim lpRect As RECT
    
    GetWindowRect hWnd, lpRect
 
    SetCursorPos lpRect.Left + (lpRect.Right - lpRect.Left) \ 2, _
        lpRect.Top + (lpRect.Bottom - lpRect.Top) \ 2

End Sub

____________________________________________________________________________________

There are two functions. The other one is below Math_GCF.
--------------------------------------------------------------------------------
Public Function Math_GCF(number1 As Double, number2 As Double) As Double
If number1 > number2 Then a = number2
If number2 > number1 Then a = number1
If number1 = number2 Then a = number1
n1 = number1: n2 = number2
h = n2 / n1
h2 = n1 / n2
If n1 > n2 Then
If Math_IsInteger(Val(h2)) Then Math_GCF = n2: Exit Function
End If
If n2 > n1 Then
If Math_IsInteger(Val(h)) Then Math_GCF = n1: Exit Function
End If
y = Math_LCM(number1, number2)
y = Val(y)
x = 1
Do: DoEvents
y = Math_LCM(Val(n1), Val(n2)) / Val(x)
b = n1 / x
c = n2 / x
If Math_IsInteger(Val(y)) Then
If Math_IsInteger(Val(b)) Then
If Math_IsInteger(Val(c)) Then
GCF = x
End If
End If
End If
x = x + 1
Loop Until x = a
Math_GCF = GCF
If n1 > n2 Then
Y1 = Math_LCM(Val(n1), Val(n2))
Y1 = Val(Y1) / Val(n2)
b = n1 / n2
c = n2 / n2
If Math_IsInteger(Val(Y1)) Then
If Math_IsInteger(Val(b)) Then
If Math_IsInteger(Val(c)) Then
GCF = n2
End If
End If
End If
End If
If n1 < n2 Then
Y1 = Math_LCM(Val(n1), Val(n2))
Y1 = Val(Y1) / Val(n1)
b = n1 / n1
c = n2 / n1
If Math_IsInteger(Val(Y1)) Then
If Math_IsInteger(Val(b)) Then
If Math_IsInteger(Val(c)) Then
GCF = n1
End If
End If
End If
End If
Math_GCF = GCF
End Function
--------------------------------------------------------------------------------
Public Function Math_IsInteger(number as double) as double
n1 = Trim(str(number))
n = InStr(1, n1, ".")
If n = 0 Then Math_IsInteger = True
If n > 0 Then Math_IsInteger = False
End Function

____________________________________________________________________________________

    //**************************************

//

    // Name: Control Panel

    // Description:access some control panel

    //     applets

    // By: Vamsi Krishna

    //**************************************

//

    Attribute VB_Name = "ControlPanel32"

    'Control Panel( CONTROL.EXE )

    '--------------------------------

    'Control Panel:

    'rundll32.exe shell32.dll,Control_RunDLL

    'Accessability Options( ACCESS.CPL )

    '---------------------------------------

    'Accessability Properties (Keyboard):

    'rundll32.exe shell32.dll,Control_RunDLL access.cpl,,1

    'Accessability Properties (Sound):

    'rundll32.exe shell32.dll,Control_RunDLL access.cpl,,2

    'Accessability Properties (Display):

    'rundll32.exe shell32.dll,Control_RunDLL access.cpl,,3

    'Accessability Properties (Mouse):

    'rundll32.exe shell32.dll,Control_RunDLL access.cpl,,4

    'Accessability Properties (General):

    'rundll32.exe shell32.dll,Control_RunDLL access.cpl,,5

    'Add/Remove Programs( APPWIZ.CPL )

    '-------------------------------------

    'Add/Remove Programs Properties (Install/Uninstall):

    'rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,1

    'Add/Remove Programs Properties (Windows Setup):

    'rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,2

    'Add/Remove Programs Properties (Startup Disk):

    'rundll32.exe shell32.dll,Control_RunDLL appwiz.cpl,,3

    'Display Options( DESK.CPL )

    '-------------------------------

    'Display Properties (Background):

    'rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,0

    'Display Properties (Screen Saver):

    'rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,1

    'Display Properties (Appearance):

    'rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,2

    'Display Properties (Settings):

    'rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3

    'Regional Settings( INTL.CPL )

    '---------------------------------

    'Regional Settings Properties (Regional Settings):

    'rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,0

    'Regional Settings Properties (Number):

    'rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,1

    'Regional Settings Properties (Currency):

    'rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,2

    'Regional Settings Properties (Time):

    'rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,3

    'Regional Settings Properties (Date):

    'rundll32.exe shell32.dll,Control_RunDLL intl.cpl,,4

    'Joystick Options( JOY.CPL )

    '-------------------------------

    'Joystick Properties (Joystick):

    'rundll32.exe shell32.dll,Control_RunDLL joy.cpl

    'Mouse/Keyboard/Printers/Fonts Options( MAIN.CPL )

    '-----------------------------------------------------

    'Mouse Properties:

    'rundll32.exe shell32.dll,Control_RunDLL main.cpl @0

    'Keyboard Properties:

    'rundll32.exe shell32.dll,Control_RunDLL main.cpl @1

    'Printers:

    'rundll32.exe shell32.dll,Control_RunDLL main.cpl @2

    'Fonts:

    'rundll32.exe shell32.dll,Control_RunDLL main.cpl @3

    'Mail and Fax Options( MLCFG32.CPL )

    '---------------------------------------

    'Microsoft Exchange Profiles (General):

    'rundll32.exe shell32.dll,Control_RunDLL mlcfg32.cpl

    'Multimedia/Sounds Options( MMSYS.CPL )

    '------------------------------------------

    'Multimedia Properties (Audio):

    'rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,0

    'Multimedia Properties (Viedo):

    'rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,1

    'Multimedia Properties (MIDI):

    'rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,2

    'Multimedia Properties (CD Music):

    'rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,3

    'Multimedia Properties (Advanced):

    'rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl,,4

    ' = = = = = = = = = = = = = = = = = = = = = = = = = = =

    'Sounds Properties:

    'rundll32.exe shell32.dll,Control_RunDLL mmsys.cpl @1

    'Modem Options( MODEM.CPL )

    '------------------------------

    'Modem Properties (General):

    'rundll32.exe shell32.dll,Control_RunDLL modem.cpl

    'Network Options( NETCPL.CPL )

    '---------------------------------

    'Network (Configuration):

    'rundll32.exe shell32.dll,Control_RunDLL netcpl.cpl

    'Password Options( PASSWORD.CPL )

    '------------------------------------

    'Password Properties (Change Passwords):

    'rundll32.exe shell32.dll,Control_RunDLL password.cpl

    'System/Add New Hardware Options( SYSDM.CPL )

    '------------------------------------------------

    'System Properties (General):

    'rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,0

    'System Properties (Device Manager):

    'rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,1

    'System Properties (Hardware Profiles):

    'rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,2

    'System Properties (Performance):

    'rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl,,3

    ' = = = = = = = = = = = = = = = = = = = = = = = = = = =

    'Add New Hardware Wizard:

    'rundll32.exe shell32.dll,Control_RunDLL sysdm.cpl @1

    'Date and Time Options( TIMEDATE.CPL )

    '-----------------------------------------

    'Date/Time Properties:

    'rundll32.exe shell32.dll,Control_RunDLL timedate.cpl

    'Microsoft Mail Postoffice Options( WGPOCPL.CPL )

    '----------------------------------------------------

    'Microsoft Workgroup Postoffice Admin:

    'rundll32.exe shell32.dll,Control_RunDLL wgpocpl.cpl

    Dim Shared XFS As Integer

    Sub ControlPanel(Filename As String)

    Dim T As Double

    On Error Resume Next

    T = Shell(Filename, 5)

    End Sub

Adding to the Favourites

Fancy adding your Web site to the list of Favourites?

This sneaky commented code snippet shows you how.

To run, simply call AddFavorite, passing your site name and Web address. This code works by grabbing the location of the Favorite folder with the help of a couple of API calls. It then creates an Internet 'link' file in that location, using the passed site name and address.

Usage

AddFavorite "VB-World", "https://vamsionnet.tripod.com/"

Code

Private Declare Function SHGetSpecialFolderLocation _
    Lib "shell32.dll" (ByVal hwndOwner As Long, _
   ByVal nFolder As SpecialShellFolderIDs, _
   pidl As Long) As Long
   
Private Declare Function SHGetPathFromIDList _
    Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
    (ByVal pidl As Long, _
    ByVal pszPath As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" _
    (ByVal pv As Long)

Public Enum SpecialShellFolderIDs
   CSIDL_DESKTOP = &H0
   CSIDL_INTERNET = &H1
   CSIDL_PROGRAMS = &H2
   CSIDL_CONTROLS = &H3
   CSIDL_PRINTERS = &H4
   CSIDL_PERSONAL = &H5
   CSIDL_FAVORITES = &H6
   CSIDL_STARTUP = &H7
   CSIDL_RECENT = &H8
   CSIDL_SENDTO = &H9
   CSIDL_BITBUCKET = &HA
   CSIDL_STARTMENU = &HB
   CSIDL_DESKTOPDIRECTORY = &H10
   CSIDL_DRIVES = &H11
   CSIDL_NETWORK = &H12
   CSIDL_NETHOOD = &H13
   CSIDL_FONTS = &H14
   CSIDL_TEMPLATES = &H15
   CSIDL_COMMON_STARTMENU = &H16
   CSIDL_COMMON_PROGRAMS = &H17
   CSIDL_COMMON_STARTUP = &H18
   CSIDL_COMMON_DESKTOPDIRECTORY = &H19
   CSIDL_APPDATA = &H1A
   CSIDL_PRINTHOOD = &H1B
   CSIDL_ALTSTARTUP = &H1D
   CSIDL_COMMON_ALTSTARTUP = &H1E
   CSIDL_COMMON_FAVORITES = &H1F
   CSIDL_INTERNET_CACHE = &H20
   CSIDL_COOKIES = &H21
   CSIDL_HISTORY = &H22
End Enum


Public Sub AddFavorite(SiteName As String, URL As String)

Dim pidl As Long
Dim intFile As Integer
Dim strFullPath As String

On Error GoTo Goodbye

intFile = FreeFile
strFullPath = Space(255)

'Check the API for the folder existence and location

If SHGetSpecialFolderLocation(0, CSIDL_FAVORITES, pidl) = 0 Then

	If pidl Then

		If SHGetPathFromIDList(pidl, strFullPath) Then

			' Trim any null characters

			If InStr(1, strFullPath, Chr(0)) Then
				strFullPath = Mid(strFullPath, 1, _
					InStr(1, strFullPath, Chr(0)) - 1)
			End If

			' Add back slash, if none exists

			If Right(strFullPath, 1) <> "\" Then
				strFullPath = strFullPath & "\"
			End If

			' Create the link

			strFullPath = strFullPath & SiteName & ".URL"
			Open strFullPath For Output As #intFile
			Print #intFile, "[InternetShortcut]"
			Print #intFile, "URL=" & URL
			Close #intFile

		End If

		CoTaskMemFree pidl

	End If

End If

Goodbye:
    
End Sub

Disabling Ctrl-Alt-Delete and Ctrl-Esc

It is often useful in Visual Basic programs to be able to disable the Ctrl-Alt-Delete key sequence. It is easily done by persuading Windows that a screen saver is running. This code also disables Ctrl-Esc, that is used to activate the Start Menu.

Declarations

Copy this code into the declarations section of your project.

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

Code

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

Use

To disable Ctrl-Alt-Delete:

Call DisableCtrlAltDelete(True)

To enable Ctrl-Alt-Delete:

Call DisableCtrlAltDelete(False)

Dial the Net Automatically

Does your application need to connect to the Internet?

Most code snippets simply show you how to display a typical connection dialog box. This method has three basic flaws; it doesn't force a dial-up, often requires the name of the connection and doesn't let you know when a connection has been made.

Thankfully this code snippet solves all those problems by using Internet Explorer's own automatic dial-up settings.

If you double-click the Internet Options icon in the Control Panel, you'll notice the Connections tab hosts a list of possible dial-up connections.

This snippet utilises a couple of little-known API calls that can automatically dial-up and disconnect from the default connection in that list – just like Internet Explorer does if it needs to connect to the Net.

Note: If the 'Never Dial a Connection' option is selected, this code will not be able to connect. It does as Internet Explorer does, and Internet Explorer simply wouldn't connect if that option was selected.

It's worth noting that this code pauses until the connection is actually made - or not, as the case may be. And that's definitely a good thing.

Code

This code is designed to be placed inside a Form with a Command Button.

Private Declare Function InternetAutodial Lib "wininet.dll" _
(ByVal dwFlags As Long, ByVal dwReserved As Long) As Long

Private Const INTERNET_AUTODIAL_FORCE_ONLINE = 1
Private Const INTERNET_AUTODIAL_FORCE_UNATTENDED = 2

Private Declare Function InternetAutodialHangup Lib "wininet.dll" _
(ByVal dwReserved As Long) As Long

Private Sub Command1_Click()

'To prompt the user to connect to the Net

If InternetAutodial(INTERNET_AUTODIAL_FORCE_ONLINE, 0) Then
	MsgBox "You're Connected!", vbInformation
End If

'To automatically start dialling

If InternetAutodial(INTERNET_AUTODIAL_FORCE_UNATTENDED, 0) Then
	MsgBox "You're Connected!", vbInformation
End If

'To disconnect an automatically dialled connection

If InternetAutodialHangup(0) Then
   MsgBox "You're Disconnected!", vbInformation
End If

End Sub

How can I move the mouse cursor?

You can use the SetCursorPos Api function. It accepts two parameters. These are the x position and the y position in screen pixel coordinates. You can get the size of the screen by calling GetSystemMetrics function with the correct constants. This example puts the mouse cursor in the top left hand corner.

t& = SetCursorPos(0,0)

This will only work if the formula has bee declared in the declarations section:

Declare Function SetCursorPosition& Lib "user32" _
(ByVal x As Long, ByVal y As Long)

Loading the Names of All Sub-Keys

Public Function GetAllKeys(hKey As Long, _
strPath As String) As Variant
Dim lRegResult As Long
Dim lCounter As Long
Dim hCurKey As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim strNames() As String
Dim intZeroPos As Integer
lCounter = 0
lRegResult = RegOpenKey(hKey, strPath, hCurKey)

Do
'initialise buffers (longest possible length=255)
lDataBufferSize = 255
strBuffer = String(lDataBufferSize, " ")
lRegResult = RegEnumKey(hCurKey, _
lCounter, strBuffer, lDataBufferSize)

If lRegResult = ERROR_SUCCESS Then

'tidy up string and save it
ReDim Preserve strNames(lCounter) As String

intZeroPos = InStr(strBuffer, Chr$(0))
If intZeroPos > 0 Then
strNames(UBound(strNames)) = Left$(strBuffer, intZeroPos - 1)
Else
strNames(UBound(strNames)) = strBuffer
End If

lCounter = lCounter + 1
Else
Exit Do
End If
Loop
GetAllKeys = strNames
End Function

This function works using the RegEnumKey function. You pass a number to the function and it returns the name of the sub key holding that position. These are numbered from 0, starting with the oldest, so you can get some idea of the age of keys using this API call. It initialises the buffer, and then makes the call. If the call returns ERROR_SUCCESS, there was a key at that number, but if it returns something else, there was either a problem, or all the keys have been retrieved. It adds the retrieved name to an array, and continues. If there was an error, it exits the loop, otherwise it just keeps going.
The function returns an array of names in a variant. You would use it as follows:

Dim SubKeys As Variant
Dim KeyLoop As Integer
SubKeys = GetAllKeys(HKEY_CURRENT_USER, vbNullString)

If VarType(SubKeys) = vbArray + vbString Then
For KeyLoop = 0 To UBound(SubKeys)
Debug.Print SubKeys(KeyLoop)
Next
End If

Dump String To File

Sub Dump_String_To_File (ByVal strString As String, ByVal strFile As String)
Dim fileFile As Integer
fileFile = FreeFile
Open strFile For Output As fileFile
Write #fileFile, strString
Close fileFile
Dim intReturn
On Error Resume Next
intReturn = Shell("c:\apps\utility\textpad\txtpad16.exe " & strFile, 1)
On Error Goto 0
End Sub

Dialog-Free Downloads

So you want to grab an Internet file, but think the Inet control is buggier than an ant's nest?

Need to start an online download but want to skip those annoying user dialog boxes?

This slice of code uses a sneaky API call to solve all your worries.

Just call the DownloadFile function, passing it your URL and local filename. The function will then use the API to download the file and return a True if successful.

Usage

MsgBox DownloadFile("http://vamsionnet.tripod.com", "c:\webpage.htm")

Code

Private Declare Function URLDownloadToFile Lib "urlmon" Alias _
    "URLDownloadToFileA" (ByVal pCaller As Long, _
    ByVal szURL As String, _
    ByVal szFileName As String, _
    ByVal dwReserved As Long, _
    ByVal lpfnCB As Long) As Long

Public Function DownloadFile(URL As String, _
    LocalFilename As String) As Boolean

    Dim lngRetVal As Long
    
    lngRetVal = URLDownloadToFile(0, URL, LocalFilename, 0, 0)
    
    If lngRetVal = 0 Then DownloadFile = True

End Function

This page was created by Vamsi Krishna.

perivamsi@hotmail.com