Jump to content

Visual Basic/Snippets

Add links
From Wikibooks, open books for an open world

TopMost Function

[edit | edit source]

The code below is useful if you want to keep your application window on top or swap your application window between staying the topmost window and behaving like a standard window. Paste the code below into a code module and call either of the two routines as required.

To make your application stay on top use this call : 

MakeTopMost Me.hwnd

To make your application window behave like a normal window use this call : 

MakeNormal Me.hwnd

  ' Created by E.Spencer - This code is public domain.
  '
  Public Const HWND_TOPMOST = -1
  Public Const HWND_NOTOPMOST = -2
  Public Const SWP_NOMOVE = &H2
  Public Const SWP_NOSIZE = &H1
  Public Const SWP_NOACTIVATE = &H10
  Public Const SWP_SHOWWINDOW = &H40
  Public Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
  Public Declare Function SetWindowPos Lib "user32" _
                          (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
                           ByVal x As Long, y, ByVal cx As Long, _
                           ByVal cy As Long, ByVal wFlags As Long) As Long
  
  Public Sub MakeTopMost(Handle As Long)
    SetWindowPos Handle, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
  End Sub
    
  Public Sub MakeNormal(Handle As Long)
    SetWindowPos Handle, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
  End Sub

Form Close Button Disable

[edit | edit source]

This was posted to the misc VB news group by Ben Baird. I include it here mainly because I found it quite handy, it details the code required to disable the Form Close button (little x button at top right of the window) whilst still keeping the button visible. To test this out open a new VB project, add a command button, paste in the code below and run it. 

  Private Declare Function GetSystemMenu Lib "user32" _
          (ByVal hwnd As Long, ByVal bRevert As Long) As Long
  Private Declare Function GetMenuItemCount Lib "user32" _
          (ByVal hMenu As Long) As Long
  Private Declare Function RemoveMenu Lib "user32" _
          (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
  Private Declare Function DrawMenuBar Lib "user32" _
          (ByVal hwnd As Long) As Long
  Private Const MF_BYPOSITION = &H400&
  Private Const MF_DISABLED = &H2&
  
  Public Sub DisableX(Frm As Form)
    Dim hMenu As Long
    Dim nCount As Long
    hMenu = GetSystemMenu(Frm.hwnd, 0)
    nCount = GetMenuItemCount(hMenu)
    Call RemoveMenu(hMenu, nCount - 1, MF_DISABLED Or MF_BYPOSITION)
    DrawMenuBar Frm.hwnd
  End Sub
  
  Private Sub Command1_Click()
    DisableX Me
  End Sub

ComboBox Automation

[edit | edit source]

The code below demonstrates how to expand and hide combo box lists via code. To test it out create a new VB project, place a command button and combo box on the form and paste in the code below. When you run the project and use the tab button to move the focus from the combo box to the command button you should notice that the combo box expands and hides. 

  Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" _
          (ByVal hwnd As Long, _
           ByVal wMsg As Long, _
           ByVal wParam As Long, _
           ByVal lParam As Long) As Long
  
  Private Const CB_SHOWDROPDOWN = &H14F
    
  Private Sub Combo1_GotFocus()
    SendMessageLong Combo1.hwnd, CB_SHOWDROPDOWN, True, 0
  End Sub
    
  Private Sub Combo1_LostFocus()
    SendMessageLong Combo1.hwnd, CB_SHOWDROPDOWN, False, 0
  End Sub
    
  Sub Form_Load()
    Combo1.AddItem "Item 1"
    Combo1.AddItem "Item 2"
    Combo1.AddItem "Item 3"
  End Sub

Reversing a String

[edit | edit source]

This code demonstrates a small function that reverses the content of a string. To test this out set up a form with a single command button and two text boxes then paste in the code below. If you now enter the text "dlroW olleH" in text box 1 and press the command button you will see the reversal in text box 2, it should read "Hello World" 

  Option Explicit

  Private Sub Command1_Click()
    Text2 = ReverseStr(Text1.Text)
  End Sub

  Private Function ReverseStr(ByVal IPStr As String) As String
    Dim i As Integer
    For i = Len(IPStr) To 1 Step -1
      ReverseStr = ReverseStr & Mid(IPStr, i, 1)
    Next
  End Function

Preventing flicker during update

[edit | edit source]

It's a common problem that controls seem to flicker as they are updated. This can be due to Windows updating a control's screen image multiple times during an update or Windows updating a control during the monitor vertical refresh. The technique below gives you the ability to lock individual controls or the entire form window during updates, this allows you to dictate to Windows when the screen updating should be done. Another way of reducing flicker is to set the form's ClipControl property to false, this forces Windows to paint the form screen as whole instead of trying to preserve the look of individual controls (it can also increase the speed of your application). For those of you having problems with flickering graphics you should investigate using the API call BitBlt (Bit Block Transfer) instead of methods like Paintpicture.

To test the code below create a new VB project and place two command buttons and a combo box on the form. The first button will populate the combo box whilst the control is locked. The second button will unlock the control and allow Windows to refresh it. Change the Hwnd to reflect the name of the control or form you want to lock. 

  Private Declare Function LockWindowUpdate Lib "User32" (ByVal hWnd As Long) As Long
  
  Private Sub Command1_Click()
    Dim i As Integer
    Combo1.Clear   ' Clear and refresh the control to show the changes
    Combo1.Refresh
    ' Lock the control to prevent redrawing
    LockWindowUpdate Combo1.hWnd
    ' Update the control
    For i = 0 To 200
      Combo1.AddItem "Entry " & i, i
    Next
    Combo1.ListIndex = 150
  End Sub
    
  Private Sub Command2_Click()
    ' Unlock
    LockWindowUpdate 0
  End Sub

Useful Date Functions

[edit | edit source]

All these functions except Lastofmonth (Elliot Spener's) were sent into PCW magazine by Simon Faulkner. I've found these date functions very handy, if you have any other useful functions let me know and I'll put them on. 

  Firstofmonth = Now() - Day(Now()) + 1
  
  Lastofmonth = DateAdd("m", 1, Date - Day(Date))
  
  Firstofyear = Now() - Datepart("y", Now()) + 1
  
  Lastofyear = Dateadd("yyyy", 1, Now() - Datepart("y", Now()))
  
  Daysinmonth = Datepart("d", Dateadd("m", 1, Now() - Day(Now))))
  
  Daysleftinyear = Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - Now()
  
  Daysleftuntilchristmas = Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - Now() - 7
  
  Daysinyear = Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - (Now() - Datepart("y", Now()))
  
  Leapyear = IIf((Dateadd("yyyy", 1, Now() - Datepart("y", Now())) - (Now() - Datepart("y", Now()))) = 366, True, False)

Blast Effect

[edit | edit source]

Makes a circular blast effect on the picture box, make sure you rename it pic. X and Y is the center of the circle, R is the radius of the blast effect 

 
  For angle=1 to 360
    pic.line (x,y) - (x + r * cos(angle*3.14159265358979/180),y + r * sin(angle*3.14159265358979/180))
  next angle

Sleep Function

[edit | edit source]

This is useful if you want to put your program in a wait state for a specific period of time. Just paste the code below into a new form to test it and attach it to a command button, then run it - you can view the time in the debug window. 1000 milliseconds = 1 second (but you probably knew that). 

  Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

  Private Sub Command1_Click()
    Debug.Print "Started - " & Time()
    Sleep 1000
    Debug.Print "Ended - " & Time()
  End Sub

Random Numbers

[edit | edit source]

Random numbers are not truly random if the random number generator isn't started, so you need to start it before using Rnd() 

Randomize()

Replace HighestNumber and LowestNumber with your own range. 

X=Int((HighestNumber - LowestNum + 1) * Rnd + LowestNumber)

Animated Mouse Cursor

[edit | edit source]

The code below demonstrates how to change the mouse cursor from the base cursor to one of the animated ones. Open up a new project, add a drop list and a command button to the form then add in the code below and run it. 

  Option Explicit
  
  Public Const GCL_HCURSOR = -12
  
  Declare Function ClipCursor Lib "user32" _
          (lpRect As Any) _
          As Long
  Declare Function DestroyCursor Lib "user32" _
          (ByVal hCursor As Any) _
          As Long
  Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
          (ByVal lpFileName As String) _
          As Long
  Declare Function SetClassLong Lib "user32" Alias "SetClassLongA" _
          (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) _
          As Long
  Declare Function GetClassLong Lib "user32" Alias "GetClassLongA" _
          (ByVal hwnd As Long, ByVal nIndex As Long) _
          As Long
  
  Private mhAniCursor As Long
  Private mhBaseCursor As Long
  Private lresult As Long
  
  Private Sub Command1_Click()
    ' Sort out the user selection
    If Combo1.ListIndex = 0 Then
      lresult = SetClassLong((Form1.hwnd), GCL_HCURSOR, mhBaseCursor)
      lresult = DestroyCursor(mhAniCursor)
    Else
      If Combo1.ListIndex = 1 Then
        mhAniCursor = LoadCursorFromFile("C:\windows\cursors\hourglas.ani")
      Else
        mhAniCursor = LoadCursorFromFile("C:\windows\cursors\globe.ani")
      End If
      lresult = SetClassLong((Form1.hwnd), GCL_HCURSOR, mhAniCursor)
    End If
  End Sub
  
  Private Sub Form_Load()
    ' Set up the list of cursor options
    Combo1.AddItem "Normal", 0
    Combo1.AddItem "HourGlass", 1
    Combo1.AddItem "Globe", 2
    Combo1.ListIndex = 0
    ' Grab the current base cursor
    mhBaseCursor = GetClassLong((hwnd), GCL_HCURSOR)
  End Sub

Adding a bitmap to a menu entry

[edit | edit source]

The code below demonstrates how to add 13x13 bitmap pictures (not icons) to the left hand of each menu entry. You can define a different bitmap for both the checked and unchecked condition (as shown) or set one of these values to zero if you don't want a bitmap shown for a particular condition.

The project uses 2 picture boxes (each holding one of the required bitmaps and set to be non visible), a button and any amount of menus and submenus. 

  Private Declare Function GetMenu Lib "user32" _
          (ByVal hwnd As Long) _
          As Long
  Private Declare Function GetSubMenu Lib "user32" _
          (ByVal hMenu As Long, ByVal nPos As Long) _
          As Long
  Private Declare Function GetMenuItemID Lib "user32" _
          (ByVal hMenu As Long, ByVal nPos As Long) _
          As Long
  Private Declare Function SetMenuItemBitmaps Lib "user32" _
          (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, _
           ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) _
          As Long
  Private Declare Function GetMenuItemCount Lib "user32" _
          (ByVal hMenu As Long) _
          As Long
  
  Private Const MF_BITMAP = &H4&
  
  Private Sub AddIconToMenus_Click()
    Dim i1 As Long, i2 As Long, Ret As Long
    Dim MnHndl As Long
    Dim SMnHndl As Long
    Dim MCnt As Long
    Dim SMCnt As Long
    Dim SMnID As Long
  
    MnHndl = GetMenu(Form1.hwnd)' Get the menu handle for the current form
    MCnt = GetMenuItemCount(MnHndl)  ' Find out how many menus there are
    For i1 = 0 To MCnt - 1               ' Process each menu entry
      SMnHndl = GetSubMenu(MnHndl, i1) 'Get the next submenu handle for this menu
      SMCnt = GetMenuItemCount(SMnHndl) 'Find out how many entries are in this submenu
      For i2 = 0 To SMCnt - 1           'Process each submenu entry
        SMnID = GetMenuItemID(SMnHndl, i2) 'Get each entry ID for the current submenu
        ' Add two pictures - one for checked and one for unchecked
        Ret = SetMenuItemBitmaps(MnHndl, SMnID, MF_BITMAP, Picture2.Picture, Picture1.Picture)
      Next i2
    Next i1
  End Sub

Convert Base Numbers

[edit | edit source]

This code demonstrates how to convert numbers to and from Decimal, Binary, Octal and Hexadecimal. 

Public Function BinToDec(Num As String) As Long
  Dim n As Integer
     n = Len(Num) - 1
     A = n
     Do While n > -1
        X = Mid(Num, ((A + 1) - n), 1)
        BinToDec = IIf((X = "1"), BinToDec + (2 ^ (n)), BinToDec)
        n = n - 1
     Loop
End Function

Public Function OctToDec(Num As String) As Long
    Dim n As Integer
    Dim Y As Integer
    n = Len(Num) - 1
    A = n
    Do While n > -7
        X = Mid(Num, ((A + 1) - n), 1)
        For Y = 1 To 7
            OctToDec = IIf((X = CStr(Y)), OctToDec + (Y * (8 ^ (n))), OctToDec)
        Next
        n = n - 1
    Loop
End Function

Public Function HexToDec(Num As String) As String
    Dim n As Integer
    Dim Y As Integer
    Dim X As String
    n = Len(Num) - 1
    A = n
    Do While n > -15
        X = Mid(Num, ((A + 1) - n), 1)
        For Y = 1 To 15
            HexToDec = IIf((X = CStr(Y)), HexToDec + (Y * (8 ^ (n))), HexToDec)
        Next
        n = n - 1
    Loop
End Function

Public Function DecToBin(DeciValue As Long, Optional NoOfBits As Integer = 8) As String
    Dim i As Integer
    On Error Resume Next
    Do While DeciValue > (2 ^ NoOfBits) - 1
        NoOfBits = NoOfBits + 8
    Loop
    DecToBin = ""
    For i = 0 To (NoOfBits - 1)
        DecToBin = CStr((DeciValue And 2 ^ i) / 2 ^ i) & DecToBin
    Next i
End Function

Public Function DecToOct(Num as Long) as Long
    DecToOct = Oct$(Num)
End Function

Public Function DecToHex(Num as String) as String
    DecToHex = Hex$(Num)
End Function

Application Launching

[edit | edit source]

The code below demonstrates how to launch the default "Open" action for any given file (which will normally mean launching the application that handles data files of that type). I've also included a variation of ShellExecute that allows you to launch the default system Internet browser and have it go immediately to a specified Web site. 

  ' Required declarations
  Private 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
  Private Declare Function GetDesktopWindow Lib "user32" () As Long
  Private Const SW_SHOWDEFAULT = 10
  Private Const SW_SHOWMAXIMIZED = 3
  Private Const SW_SHOWMINIMIZED = 2
  Private Const SW_SHOWMINNOACTIVE = 7
  Private Const SW_SHOWNA = 8
  Private Const SW_SHOWNOACTIVATE = 4
  Private Const SW_SHOWNORMAL = 1
  
  Private Sub Command1_Click()
    ' Open the browser and goto a specified site
    Dim DWHdc As Long, Ret As Long
    Dim PathAndFile As String
    PathAndFile = File1.Path & "\" & File1.filename
    ' Use the desktop window as the parent
    DWHdc = GetDesktopWindow()
    Ret = ShellExecute(DWHdc, "Open", Text1.Text, "", "c:\", SW_SHOWMAXIMIZED)
  End Sub
  
  Private Sub Dir1_Change()
    File1.Path = Dir1.Path
  End Sub
  
  Private Sub Drive1_Change()
    Dir1.Path = Drive1.Drive
  End Sub
  
  Private Sub File1_DblClick()
    ' Launch the default "Open" action for the file
    Dim DWHdc As Long, Ret As Long
    Dim PathAndFile As String
    PathAndFile = File1.Path & "\" & File1.filename
    ' Use the desktop window as the parent
    DWHdc = GetDesktopWindow()
    Ret = ShellExecute(DWHdc, "Open", PathAndFile, "", File1.Path, SW_SHOWNORMAL)
  End Sub

Rounding Things Up

[edit | edit source]

If you're bored of rectangular controls on rectangular forms then try the code below. Open a new project, put a command button on it, paste this code in and then run it. You should see a round button on a round form, it works on most controls. The code is fairly straightforward, you calculate the size of the ellipse required and feed this through two API calls. With a bit of playing you can get some very odd effects. 

  Private hwndDest As Long
  Private Declare Function CreateEllipticRgn Lib "gdi32" _
                           (ByVal X1 As Long, ByVal Y1 As Long, _
                            ByVal X2 As Long, ByVal Y2 As Long) As Long
  Private Declare Function SetWindowRgn Lib "user32" _
                           (ByVal hWnd As Long, ByVal hRgn As Long, _
                            ByVal bRedraw As Long) As Long

  Private Sub Command1_Click()
    Unload Me
  End Sub

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

TCP/Winsock - Point-to-Point Connection

[edit | edit source]

This is a client-server Point-to-Point TCP over Winsock snippet, which settings are hard-coded. The snippet will connect to the server through the loopback adapter through port 50000, and the conversation would be the client sending the server a "Hello World" message which the server would show on a MsgBox. The server could only accept one connection from a client, if there is a second connection request from another client it would disconnect the first connection (thus, Point-to-Point). For a Point-to-Multipoint code (the server allows multiple connection from multiple client) see below.

Client Code

[edit | edit source]

Add the following controls

  • Winsock Control - Name="sckClient"
  • Command Button - Name="Command1", Caption="Say "Hello World""
  • Command Button - Name="Command2", Caption="Make a Connection"
  • (Optional) Timer - Name="Timer1", Interval="1", Enabled="True"
    Option Explicit
    
    Private Sub Command1_Click()
        ' If connected, send data, if not, popup a msgbox telling to connect first
        If sckClient.State <> sckConnected Then
            MsgBox "Connect First"
        Else
            sckClient.SendData "Hello World"
        End If
    End Sub
    
    Private Sub Command2_Click()
        ' If there is already a connection, close it first, 
        ' failure of doing this would result in an error
        If sckClient.State <> sckClosed Then sckClient.Close
        
        ' OK, the winsock is free, we could open a new connection
        sckClient.Connect "127.0.0.1", 50000
    End Sub
    
    Private Sub Timer1_Timer()
        ' Code for seeing the status of the winsock in the form window.
        ' For the meaning of the Status Code, go to the Object Browser (F2) and search for Winsock
        Me.Caption = sckClient.State
    End Sub

Server Code

[edit | edit source]

Add the following control

  • Winsock Control - Name="sckServer"
  • (Optional) Timer - Name="Timer1", Interval="1", Enabled="True"
    Option Explicit
    
    Private Sub Form_Load()
        ' Listen to port 50000 for incoming connection from a client
        sckServer.LocalPort = 50000
        sckServer.Listen
    End Sub
    
    Private Sub sckServer_Close()
        ' If the connection is closed, restart the listening routine 
        ' so other connection can be received.
        sckServer.Close
        sckServer.Listen
    End Sub
    
    Private Sub sckServer_ConnectionRequest(ByVal requestID As Long)
        ' If the connection is not closed close it first before accepting a connection
        ' You can alter this behaviour, like to refuse the second connection
        If sckServer.State <> sckClosed Then sckServer.Close
        sckServer.Accept requestID
    End Sub
    
    Private Sub sckServer_DataArrival(ByVal bytesTotal As Long)
        Dim Data As String
        ' Receive the data (GetData), 
        ' Clear the data buffer (automatic with calling GetData),
        ' Display the data on a MsgBox
        sckServer.GetData Data
        MsgBox Data
    End Sub
    
    Private Sub Timer1_Timer()
        ' Code for seeing the status of the winsock in the form window.
        ' For the meaning of the Status Code, go to the Object Browser (F2) and search for Winsock
        Me.Caption = sckServer.State
    End Sub

TCP/Winsock - Point-to-MultiPoint Connection

[edit | edit source]

This snippet is the same as the TCP/Winsock - Point-to-Point Connection above, but this code allows the server to receive multiple connection from multiple client simultaneously. This behavior is achieved by using Control Array. The Winsock Control Array index 0 is a special one, since it is never opened, it'll only listen for incoming connection, and assign to another Winsock control if there is an incoming connection. The server code is coded to reuse existing WinSock control that is already closed to receive new connection. The client code is the same as with the Point-to-Point snippet. The client will never unload Winsock control that is already open. You should understand Point-to-Point Connection before trying to implement Point-to-Multipoint connection.

Client Code

[edit | edit source]

The same with client code for Point-to-Point Client Code

Server Code

[edit | edit source]

Add the following control

  • Winsock Control - Name="sckServer", Index="0"
  • (Optional) Timer - Name="Timer1", Interval="1", Enabled="True"
    Private Sub Form_Load()
        ' Open a listening routine on port 50000
        sckServer(0).LocalPort = 50000
        sckServer(0).Listen
    End Sub
    
    Private Sub sckServer_Close(Index As Integer)
        ' Close the WinSock so it could be reopened if needed
        sckServer(Index).Close
    End Sub
    
    Private Sub sckServer_ConnectionRequest(Index As Integer, ByVal requestID As Long)
        Dim sock As Winsock
        ' If there is any closed Winsock, accept on that Winsock
        For Each sock In sckServer
            If sock.State = sckClosed Then
                sock.Accept requestID
                Exit Sub
            End If
        Next
        
        ' Else make a new Winsock
        Load sckServer(sckServer.UBound + 1)
        sckServer(sckServer.UBound).Accept requestID
    End Sub
    
    
    Private Sub sckServer_DataArrival(Index As Integer, ByVal bytesTotal As Long)
        Dim Data As String
        ' Receive the data (GetData) for the connection that is receiving, 
        ' Clear the data buffer (automatic with calling GetData) of the receiving connection,
        ' Display the data on a MsgBox with the index of the receiving Winsock
        sckServer(Index).GetData Data, vbString
        MsgBox Data & vbCrLf & Index
    End Sub
    
    Private Sub Timer1_Timer()
        Dim conn As Winsock
        ' Display the status for all connection on the window bar
        ' The status code is space-separated
        Me.Caption = ""
        For Each conn In sckServer
            Me.Caption = Me.Caption & " " & conn.State
        Next
    End Sub


Previous: Optimizing Visual Basic Contents Next: The Language
Retrieved from "https://en.wikibooks.org/w/index.php?title=Visual_Basic/Snippets&oldid=3678629"