Visual Basic > Forms

Create a progress bar in a status bar (works on MDI forms)

Create a progress bar in a status bar (works on MDI forms)

The following code creates a progress bar in the pannel of a status bar. This code works on MDI forms:


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 Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'Purpose   :    Creates a picturebox to display progress in the pannel of a status bar.
'Inputs    :    sbStatus                The status bar to display to progress bar on.
'               vPannel                 The pannel to display the progress bar in (can be an index or the Key name).
'               lPercentComplete        The percentage complete.
'               lColor                  The color of the progress bar.
'Outputs   :    Returns True on success.
'Notes     :    Need to add the "Microsoft Windows Common Controls" component
'               Works in MDI forms
'               Example usuage:
'               StatusBarProgress StatusBar1, 1, 10  'Draws the progress bar 10% complete in pannel 3

Function StatusBarProgress(sbStatus As StatusBar, vPannel As Variant, ByVal lPercentComplete As Long, Optional lColor As OLE_COLOR = vbBlue) As Boolean
    Const WM_USER = &H400, SB_GETRECT = (WM_USER + 10)
    Dim tRect As RECT, fPercent As Single, lLenBar As Long
    Static oPict As PictureBox
    
    On Error GoTo ErrFailed
    If oPict Is Nothing Then
        'Create a hidden image on the form
        Set oPict = sbStatus.Parent.Controls.Add("VB.PictureBox", "DynamicPictureBox")
        oPict.AutoRedraw = True
    End If
    
    fPercent = lPercentComplete / 100
    
    'Get the panel coordinates
    SendMessage sbStatus.hwnd, SB_GETRECT, sbStatus.Panels(vPannel).Index - 1, tRect

    With oPict
        'Resize image
        lLenBar = fPercent * (tRect.Right - tRect.Left + 2) * Screen.TwipsPerPixelX
        .Move 0, 0, lLenBar, (tRect.Bottom - tRect.Top + 1) * Screen.TwipsPerPixelY
        'Set the image backcolor
        .BackColor = lColor
        'Set the panels image to the picture box image
        sbStatus.Panels(vPannel).AutoSize = sbrNoAutoSize
        Set sbStatus.Panels(vPannel).Picture = .Image
    End With

    StatusBarProgress = True
    
    Exit Function

ErrFailed:
    Debug.Print "Error in StatusBarProgress: " & Err.Description
    Debug.Assert False
    StatusBarProgress = False
End Function


'Purpose   :    Creates a progress bar in the pannel of a status bar using a picture box.
'Inputs    :    sbStatus                The status bar to display to progress bar on.
'               vPannel                 The pannel to display the progress bar in (can be an index or the Key name).
'               lPercentComplete        The percentage complete.
'               lColor                  The color of the progress bar.
'Outputs   :    Returns True on success.
'Notes     :    Works in MDI forms
'               Example usuage:
'               StatusBarProgress2 StatusBar1, 1, 10  'Draws the progress bar 10% complete in pannel 3

Function StatusBarProgress2(sbStatus As StatusBar, vPannel As Variant, ByVal lPercentComplete As Long, Optional lColor As OLE_COLOR = &H9D9793) As Boolean
    Static soProgressBar As ProgressBar, slLastColor As Long
    Const clBorder As Long = 25
    Const WM_USER = &H400, CCM_FIRST As Long = &H2000&
    Const CCM_SETBKCOLOR As Long = (CCM_FIRST + 1), PBM_SETBKCOLOR As Long = CCM_SETBKCOLOR, PBM_SETBARCOLOR As Long = (WM_USER + 9)
    
    On Error GoTo ErrFailed
    If soProgressBar Is Nothing Then
        Set soProgressBar = Controls.Add("MSComctlLib.ProgCtrl.2", "ProgressBar1")
        Call SetParent(soProgressBar.hwnd, sbStatus.hwnd)
        soProgressBar.Visible = True
        soProgressBar.BorderStyle = ccNone
        soProgressBar.Appearance = ccFlat
        With sbStatus.Panels(vPannel)
            soProgressBar.Move .Left + clBorder, Screen.TwipsPerPixelY * 2 + clBorder, .Width - (clBorder * 2), sbStatus.Height - (Screen.TwipsPerPixelY * 3) - (clBorder * 2)
        End With
        soProgressBar.Min = 0
        soProgressBar.Max = 100
    End If
    
    soProgressBar.Value = lPercentComplete
    StatusBarProgress2 = True
    
    If lColor <> slLastColor Then
        'change the bar colour
        slLastColor = lColor
        Call SendMessage(soProgressBar.hwnd, PBM_SETBARCOLOR, 0&, ByVal lColor)
    End If
    
    Exit Function

ErrFailed:
    Debug.Print "Error in StatusBarProgress2: " & Err.Description
    Debug.Assert False
    StatusBarProgress2 = False
End Function