• Home
 · 
• Custom Controls/Forms/Menus
 · 
• Adding a Custom PhotoShop-Style ProgressBar into StatusBar

Adding a Custom PhotoShop-Style ProgressBar into StatusBar

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




Rate Adding a Custom PhotoShop-Style ProgressBar into StatusBar

• 1
• 2
• 3
• 4
• 5

(2(2 Vote))

'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