by Dwi Chris Santo (1 Submission)
Category: Custom Controls/Forms/Menus
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Tue 3rd September 2002
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Adding a Custom PhotoShop-Style ProgressBar into StatusBar
API Declarations
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
VBcoders
'Add a label over the picturebox (Label1).
'Add the following code to the form:
Option Explicit
Private unit As Long
Private upperlimit As Long
Private Progress As Long
Private defProgBarHwnd As Long
Private bvStop As Boolean
Private Sub Command1_Click()
Dim pading As Long
pading = 40
AttachProgBar tbFlood, StatusBar1, 2, pading
Label1.Height = tbFlood.Height
Label1.Width = tbFlood.Width
End Sub
Private Sub Command2_Click()
Dim i As Long
unit = 1
upperlimit = 250
Progress = 1
bvStop = False
Label1.Caption = "Processing..."
For i = 1 To upperlimit
Progress = Progress + unit
FloodUpdatePercent upperlimit, Progress
If bvStop Then Exit For
Sleep 100
Next i
Label1.Caption = "Commplete"
Progress = 0
End Sub
Private Sub Command5_Click()
Unload Me
End Sub
Private Sub Command3_Click()
bvStop = True
End Sub
Private Sub Form_Load()
'position the form 1/3 up the screen
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 3
'set the flood's initial attributes
'white text (trust me, I know it says backcolor !)
tbFlood.BackColor = &HFFFFFF
tbFlood.DrawMode = 10
'solid fill
tbFlood.FillStyle = 0
unit = 1
upperlimit = 250
Command2.Caption = "Start"
Command1.Caption = "Set Progress Bar"
Command3.Caption = "Stop"
'initialize the controls
End Sub
Private Sub FloodUpdatePercent(upperlimit As Long, Progress As Long)
Dim msg As String
'make sure that the flood display hasn't already hit 100%
If Progress <= upperlimit Then
'error trap in case the code attempts
'to set the scalewidth greater than
'the max allowable
If Progress > tbFlood.ScaleWidth Then
Progress = tbFlood.ScaleWidth
End If
'erase the flood
tbFlood.Cls
'set the ScaleWidth equal to the upper limit of the items to count
tbFlood.ScaleWidth = upperlimit
'format the progress into a percentage string to display
msg = Format$(CLng((Progress / tbFlood.ScaleWidth) * 100)) + "%"
'calculate the string's X & Y coordinates
'in the PictureBox ... here, centered
tbFlood.CurrentX = (tbFlood.ScaleWidth - tbFlood.TextWidth(msg)) \ 2
tbFlood.CurrentY = (tbFlood.ScaleHeight - tbFlood.TextHeight(msg)) \ 2
'print the percentage string in the text colour
tbFlood.Print msg
'print the flood bar to the new progress length in the line colour
tbFlood.Line (0, 0)-(Progress, tbFlood.ScaleHeight), tbFlood.ForeColor, BF
'allow the flood to complete drawing
DoEvents
End If
End Sub
Private Function AttachProgBar(pb As PictureBox, sb As StatusBar, nPanel As Long, pading As Long)
If defProgBarHwnd = 0 Then
'change the parent
defProgBarHwnd = SetParent(pb.hwnd, sb.hwnd)
With sb
'adjust statusbar. Doing it this way
'relieves the necessity of calculating
'the statusbar position relative to the
'top of the form. It happens so fast
'the change is not seen.
.Align = vbAlignTop
.Visible = False
'change, move, set size and re-show
'the progress bar in the new parent
With pb
.Visible = False
.Align = vbAlignNone
.Appearance = ccFlat
.BorderStyle = ccNone
.Width = sb.Panels(nPanel).Width
.Move (sb.Panels(nPanel).Left + pading), _
(sb.Top + pading), _
(sb.Panels(nPanel).Width - (pading * 2)), _
(sb.Height - (pading))
.Visible = True
.ZOrder 0
End With
'restore the statusbar to the
'bottom of the form and show
.Panels(nPanel).AutoSize = sbrNoAutoSize
.Align = vbAlignBottom
.Visible = True
End With
End If
End Function
