VB and VBA Users Source Code: Create a progress bar in a status bar (works on MDI forms)
[
Home
|
Contents
|
Search
|
Reply
| Previous | Next ]
VB/VBA Source Code
Create a progress bar in a status bar (works on MDI forms)
By:
Andrew Baker
Email (spam proof):
Email the originator of this post
Date:
Monday, June 17, 2002
Hits:
2458
Category:
Windows Forms/GUI/Controls/Graphics
Article:
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. 'Author : Andrew Baker 'Date : 25/03/2001 '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. 'Author : Andrew Baker 'Date : 25/03/2001 '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
Terms and Conditions
Support this site
Download a trial version of the Excel Workbook Rebuilder
