fNMRPrgs, Full-form progress bar (frm77)

Show progress bar inside userform, with option to control lots of things.
This is the updated version from Frm73
Instead of showing whole new window for progressbar, we can now show the progressbar inside userform, covering other controls in a smart way with options to change in code or during function call.

CodeFunctionName
What is this?

Public

Tested

Original Work
To install ....
Create Frame (visible=false)
Add inside that frame 5 label controls and 1 command button, named as in screenshot attached
Paste below code in it or use same code from frm77.frm attached

' Start of Frm77 code ....

Public NMRPrgs_Cancel

Sub NMRPrgstest()
    UserForm1.Show 1
End Sub
Private Sub CommandButton1_Click()
    NMRPrgs_Cancel = 0
    For I = 1 To 300
        NMRPrgs_Progress "Reading ...", I, 300, "Please wait ...", , , 0
        For j = 1 To 200
            DoEvents
            If NMRPrgs_Cancel = 1 Then Exit For
        Next
        DoEvents
        If NMRPrgs_Cancel = 1 Then Exit For
    Next
End Sub



Sub NMRPrgs_Progress(ProgressCaption, Progress, Optional Progress100 = 100, Optional MainCaption = "Large caption", Optional PrgsColor = &HE4CCB8, Optional PrgsFormat = "#.0%", Optional HideWhenDone = 0)
    ' Setup controls
    '    Only if we need to
    '
    If Not fNMRPrgs.Visible Then
        NMRPrgs_Setup
        DoEvents
    End If
    ' Refresh progress
    NMRPrgs_L1.Caption = MainCaption
    NMRPrgs_L3.BackColor = PrgsColor
    NMRPrgs_L3.Width = Progress * (NMRPrgs_L2.Width - 4) / Progress100
    NMRPrgs_L4.Caption = Format(Progress / Progress100, PrgsFormat)
    NMRPrgs_L5.Caption = ProgressCaption & " " & Progress & " of " & Progress100
    DoEvents
    If Progress >= Progress100 Then
        CmdNMRPrgsCancel.Caption = "Hide"
        If HideWhenDone = 1 Then NMRPrgs_End
    End If
End Sub
Sub NMRPrgs_Setup()
    '
    ' Setup controls
    '
   
    Prgs_Height = 90
   
    MFW = fNMRPrgs.Parent.Width
    MFH = fNMRPrgs.Parent.Height
    Prgs_Top = (MFH / 2) - (Prgs_Height / 2) - 20 ' 120
   
    fNMRPrgs.Caption = ""
    NMRPrgs_Cancel = 0
    CmdNMRPrgsCancel.Caption = "Cancel"
   
    fNMRPrgs.Left = 25
    fNMRPrgs.Top = 25
    fNMRPrgs.Width = MFW - 50
    fNMRPrgs.Height = MFH - 60
    fNMRPrgs.SpecialEffect = fmSpecialEffectFlat
'    fNMRPrgs.SpecialEffect = fmSpecialEffectEtched
   
    NMRPrgs_L1.Left = 5 ' Top message = Please wait ...
    NMRPrgs_L1.Top = Prgs_Top - 25
    NMRPrgs_L1.Width = fNMRPrgs.Width - 10
    NMRPrgs_L1.Height = 25
    NMRPrgs_L1.TextAlign = fmTextAlignCenter
    NMRPrgs_L1.Caption = ""
   
    NMRPrgs_L2.Left = 5 ' Outside Main Progress box
    NMRPrgs_L2.Top = Prgs_Top
    NMRPrgs_L2.Width = NMRPrgs_L1.Width
    NMRPrgs_L2.Height = Prgs_Height
'    NMRPrgs_L2.SpecialEffect = fmSpecialEffectEtched
    NMRPrgs_L2.SpecialEffect = fmSpecialEffectSunken
    NMRPrgs_L2.Caption = ""
   
    NMRPrgs_L3.Left = 7 ' Inside colored Progress box
    NMRPrgs_L3.Top = Prgs_Top + 2
    NMRPrgs_L3.Width = NMRPrgs_L1.Width - 4
    NMRPrgs_L3.Height = Prgs_Height - 4
    NMRPrgs_L3.SpecialEffect = fmSpecialEffectFlat
    NMRPrgs_L3.BackColor = RGB(256, 256, 11)
    NMRPrgs_L3.Caption = ""
   
    NMRPrgs_L4.Left = 7 ' Large caption = 50%
    NMRPrgs_L4.Top = Prgs_Top + 10 '(Prgs_Height / 2)
    NMRPrgs_L4.Width = NMRPrgs_L3.Width
    NMRPrgs_L4.Height = 40 'Prgs_Height - 4
    NMRPrgs_L4.BackStyle = fmBackStyleTransparent
    NMRPrgs_L4.TextAlign = fmTextAlignCenter
    NMRPrgs_L4.Caption = ""
    NMRPrgs_L4.Font.Size = 24
   
    NMRPrgs_L5.Left = 7 ' Small caption = Reading ... 150 of 300
    NMRPrgs_L5.Top = NMRPrgs_L4.Top + NMRPrgs_L4.Height
    NMRPrgs_L5.Width = NMRPrgs_L3.Width 'fNMRPrgs.Width - 14
    NMRPrgs_L5.Height = Prgs_Height - 14
    NMRPrgs_L5.BackStyle = fmBackStyleTransparent
    NMRPrgs_L5.TextAlign = fmTextAlignCenter
    NMRPrgs_L5.Caption = ""
    NMRPrgs_L5.Font.Size = 12
   
    CmdNMRPrgsCancel.Left = (fNMRPrgs.Width / 2) - (CmdNMRPrgsCancel.Width / 2)
    CmdNMRPrgsCancel.Top = Prgs_Top + Prgs_Height + 2
   
    fNMRPrgs.ZOrder 0
    fNMRPrgs.Visible = True
    fNMRPrgs.Parent.Repaint
   
End Sub
Private Sub CmdNMRPrgsCancel_Click()
    NMRPrgs_End
End Sub
Sub NMRPrgs_End()
    NMRPrgs_Cancel = 1
    fNMRPrgs.Visible = False
    fNMRPrgs.Parent.Repaint
End Sub


ProgressCaption, Progress, Optional Progress100 = 100, Optional MainCaption = "Large caption", Optional PrgsColor = &HE4CCB8, Optional PrgsFormat = "#.0%", Optional HideWhenDone = 0



Sub NMRPrgstest()
    UserForm1.Show 1
End Sub
Private Sub CommandButton1_Click()
    NMRPrgs_Cancel = 0
    For I = 1 To 300
        NMRPrgs_Progress "Reading ...", I, 300, "Please wait ...", , , 0
        For j = 1 To 200
            DoEvents
            If NMRPrgs_Cancel = 1 Then Exit For
        Next
        DoEvents
        If NMRPrgs_Cancel = 1 Then Exit For
    Next
End Sub

Views 161

Downloads 33

CodeID
DB ID