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.
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
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 196
Downloads 43
CodeID
DB ID