20
\$\begingroup\$

Any future updates can be found atExcel-VBA-ProgressBar

What I've been using so far

For the last 6 years I've been using a progress form which I wrote in VBA using just Windows API calls. The code (not for review) is here:gist. It has a small demo as well.

It worked because there was noDoEvents call. So, although the form is not modal by any means, the user cannot interact with Excel itself unless stepping through code, and the bar still updates visually without freezing. I also liked that the entire code is in a single class module and never crashed.

However, there are 2 main drawbacks:

  1. It only works on Windows, not Mac
  2. The user cannot cancel the form as there are no events. This could be done using subclassing but I definitely don't want to go into that rabbit hole - I don't want any crashes due to Stop button being pressed or system timeouts.

There are also smaller issues like flickering.

What I wanted to achieve

I wanted a progress bar that would solve the next points:

  1. Works on both Win and Mac
  2. The user can cancel the displayed form via the X button, if allowed
  3. The user can cancel via the Esc key, if allowed
  4. The form displayed can be Modal but also Modeless, as needed
  5. The progress bar would call a 'worker' routine
  6. The 'worker' routine called would be able to return a value if it's aFunction
  7. The 'worker' routine would accept a variable number of parameters and would be able to change themByRef if needed
  8. The 'worker' routine does not need to accept the progress bar instance at a specific position in the parameter list, or at all (for whatever reason - a global variable could be used, although I would not recommend)
  9. The 'worker' routine can be a macro in a workbook or a method on an object
  10. The main progress bar class doesn't need a global instance nor a factory
  11. Easy customizable properties
  12. Has the ability to show how much time has elapsed and an approximation of how much time is left which can be useful for tasks where steps are almost equal but also the ability to turn the time off when not needed or inaccurate
  13. The number of classes/modules is at a minimum. Would have preferred just one as the gist mentioned above but that's not realistic in plain VBA with no API. For exampleCreateObject("Forms.Form.1") does indeed create a form but it cannot be displayed. So, realistically, a class module and an actualUserForm module are needed at the very least
  14. The userform module has a minimum of code. Basically, just events, that are going to get raised but nothing else and no other logic whatsoever
  15. The userform module has no design time controls. This would make it easy to just create a new form in 3 steps: insert new form, rename, add events code. So, controls added at runtime
  16. No interfaces because ofthis bug. To be honest I never got to refactor those particular large projects (mentioned in the link) and it might be the module size that is the issue (as suggested by @MathieuGuindon). But then there's also number 13 above - I prefer less modules

What's already available

On a quick search, a lot of progress bars/forms popped-up but most of them were using Win APIs which defeated the number 1 issue I had - not working on Mac. Plus, I have my own API (old an ugly) API implementation as in the mentioned gist.

And then countless posts using a Modeless userform which defeated the number 4 point raised above - need both Modal and Modeless.

And then I found the excellent articleThe Reusable Progress Indicator written by @MathieuGuindon. I remember reading it in a hurry when it was first posted about 3 years ago but back then thegist I linked was enough for what I was doing. Admittedly the article is rather old and the author mentioned in a few other places and articles that he needs to revisit the progress indicator. Regardless, I've read it carefully and I loved the idea of displaying a Modal form which then raises anActivated event. That's the spark I needed to start implementing my own form that solves all the other points raised above. Many thanks to the author!

Implementation

Userform

Any new userform is fine. No controls are needed and the form can be of any size. Needed:

  1. Then userform name must beProgressForm
  2. The code inside the form is:
Option ExplicitPublic Event Activate()Public Event QueryClose(Cancel As Integer, CloseMode As Integer)Private Sub UserForm_Activate()    RaiseEvent ActivateEnd SubPrivate Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)    RaiseEvent QueryClose(Cancel, CloseMode)End Sub

The form itself can be shown independently but is rather useless on it's own.

Reference

In order to achieve point 7 (variable number of parameters which preserve theByRef flag) I needed a way to safely copy aParamArray into a regular array. Unfortunately that cannot be done natively so I am using the functionCloneParamArray from my own repositoryVBA-MemoryTools. I could argue that the cloning is somewhat natively as all the supporting methods copy memory natively viaByRef Variants but that's not important. So,LibMemory bas module is needed because otherwise no arguments could be changed by reference while a Modal form is displayed.

Class

TheProgressBar class code:

Option ExplicitPrivate WithEvents m_form As ProgressFormPrivate m_allowCancel As BooleanPrivate m_cancelled As BooleanPrivate m_currentValue As DoublePrivate m_isAutoCentered As BooleanPrivate m_isRunning As BooleanPrivate m_procedure As StringPrivate m_result As VariantPrivate m_showTime As BooleanPrivate m_showType As FormShowConstantsPrivate m_startTime As DatePrivate m_targetBook As WorkbookPrivate m_targetObj As ObjectPrivate m_args() As Variant'ControlsPrivate m_info1 As MSForms.LabelPrivate m_info2 As MSForms.LabelPrivate m_barFrame As MSForms.FramePrivate m_bar As MSForms.LabelPrivate m_elapsed As MSForms.LabelPrivate m_remaining As MSForms.LabelPrivate m_percent As MSForms.LabelPrivate WithEvents m_escButton As MSForms.CommandButton#If Mac Then#ElseIf VBA7 ThenPrivate Declare PtrSafe _Function rtcCallByName Lib "VBE7.DLL" (ByVal targetObj As Object _                                     , ByVal procNamePtr As LongPtr _                                     , ByVal vCallType As VbCallType _                                     , ByRef args() As Any _                                     , Optional ByVal lcid As Long) As Variant#ElsePrivate Declare _Function rtcCallByName Lib "msvbvm60" (ByVal targetObj As Object _                                     , ByVal procNamePtr As Long _                                     , ByVal vCallType As VbCallType _                                     , ByRef args() As Any _                                     , Optional ByVal lcid As Long) As Variant#End If'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'Class events'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~Private Sub Class_Initialize()    Set m_form = New ProgressForm    BuildForm    With Me        .AllowCancel = False        .Caption = "Progress..."        .Info1 = "Please wait..."        .Info2 = vbNullString        .ShowTime = False        .ShowType = vbModal        .CenterOnApplication    End WithEnd SubPrivate Sub Class_Terminate()    TryHideForm    Set m_form = NothingEnd SubPrivate Sub TryHideForm()    On Error Resume Next 'Avoid error 402    m_form.Hide    On Error GoTo 0End Sub'*******************************************************************************'Builds the necessary controls and alignment at runtime'*******************************************************************************Private Sub BuildForm()    Const progIDLabel As String = "Forms.Label.1"    Const progIDFrame As String = "Forms.Frame.1"    Const progIDButton As String = "Forms.CommandButton.1"    Const sideValue As Single = 6    '    m_form.Font.Name = "Tahoma"    m_form.Font.Size = 8.25    m_form.Width = 300    '    Set m_info1 = m_form.Controls.Add(progIDLabel)    CastToControl(m_info1).Move sideValue, sideValue    TextAlignLabel m_info1, False, True, fmTextAlignLeft    '    Set m_info2 = m_form.Controls.Add(progIDLabel)    CastToControl(m_info2).Move sideValue, CastToControl(m_info1).Top + 12    TextAlignLabel m_info2, False, True, fmTextAlignLeft    '    Set m_barFrame = m_form.Controls.Add(progIDFrame)    CastToControl(m_barFrame).Move sideValue, CastToControl(m_info2).Top + 15 _        , m_form.InsideWidth - sideValue * 2, 15    m_barFrame.SpecialEffect = fmSpecialEffectSunken    '    Set m_bar = m_barFrame.Controls.Add(progIDLabel)    CastToControl(m_bar).Move 0, 0, 15, 15    m_bar.BackColor = &HC07000    '    Set m_elapsed = m_form.Controls.Add(progIDLabel)    CastToControl(m_elapsed).Move sideValue, CastToControl(m_barFrame).Top + 18    TextAlignLabel m_elapsed, False, True, fmTextAlignLeft    '    Set m_remaining = m_form.Controls.Add(progIDLabel)    CastToControl(m_remaining).Move sideValue, CastToControl(m_elapsed).Top + 12    TextAlignLabel m_remaining, False, True, fmTextAlignLeft    With CastToControl(m_remaining)        m_form.Height = .Top + .Height + sideValue    End With    With m_form       .Height = .Height * 2 - .InsideHeight    End With    '    Set m_percent = m_form.Controls.Add(progIDLabel)    CastToControl(m_percent).Move CastToControl(m_barFrame).Width _        + sideValue - 60, CastToControl(m_elapsed).Top, 60    TextAlignLabel m_percent, False, False, fmTextAlignRight    '    Set m_escButton = m_form.Controls.Add(progIDButton)    With CastToControl(m_escButton)        .Cancel = True 'Allows for the form to be closed by pressing the Esc key        .Move 0, 0, 0, 0    End WithEnd SubPrivate Function CastToControl(ByVal c As MSForms.Control) As MSForms.Control    Set CastToControl = cEnd FunctionPrivate Sub TextAlignLabel(ByVal labelControl As MSForms.Label _                         , ByVal wordWrapValue As Boolean _                         , ByVal autoSizeValue As Boolean _                         , ByVal textAlignValue As fmTextAlign)    With labelControl        .WordWrap = wordWrapValue        .AutoSize = autoSizeValue        .TextAlign = textAlignValue    End WithEnd Sub'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'Form/Control events'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~Private Sub m_form_Activate()    If m_showType = vbModal Then RunProcedureEnd SubPrivate Sub m_form_QueryClose(Cancel As Integer, CloseMode As Integer)    If CloseMode = VbQueryClose.vbFormControlMenu Then 'User pressed X button        Cancel = True        OnCancel    End IfEnd SubPrivate Sub m_escButton_Click()    OnCancelEnd SubPrivate Sub OnCancel()    If Not m_allowCancel Then Exit Sub    '    If MsgBox(Prompt:="Are you sure you want to cancel?" _            , Buttons:=vbQuestion + vbYesNo _            , Title:="Please confirm" _    ) = vbYes Then        m_form.Hide        m_cancelled = True    End IfEnd Sub'==============================================================================='Caption text'===============================================================================Public Property Get Caption() As String    Caption = m_form.CaptionEnd PropertyPublic Property Let Caption(ByVal formCaption As String)    m_form.Caption = formCaption    RefreshEnd Property'==============================================================================='Info1 text'===============================================================================Public Property Get Info1() As String    Info1 = m_info1.CaptionEnd PropertyPublic Property Let Info1(ByVal info1Label As String)    m_info1.Caption = info1Label    RefreshEnd Property'==============================================================================='Info2 text'===============================================================================Public Property Get Info2() As String    Info2 = m_info2.CaptionEnd PropertyPublic Property Let Info2(ByVal info2Label As String)    m_info2.Caption = info2Label    RefreshEnd Property'==============================================================================='Color of the bar'===============================================================================Public Property Get BarColor() As Long    BarColor = m_bar.BackColorEnd PropertyPublic Property Let BarColor(ByVal colorCode As Long)    m_bar.BackColor = colorCode    RefreshEnd Property'==============================================================================='Color of the frame (bar background)'===============================================================================Public Property Get BarBackColor() As Long    BarBackColor = m_barFrame.BackColorEnd PropertyPublic Property Let BarBackColor(ByVal colorCode As Long)     m_barFrame.BackColor = colorCode     RefreshEnd Property'==============================================================================='Enables/disables the X button on the progress form'===============================================================================Public Property Get AllowCancel() As Boolean    AllowCancel = m_allowCancelEnd PropertyPublic Property Let AllowCancel(ByVal canCancel As Boolean)     m_allowCancel = canCancelEnd Property'==============================================================================='Can be modal or modeless'===============================================================================Public Property Get ShowType() As FormShowConstants    ShowType = m_showTypeEnd PropertyPublic Property Let ShowType(ByVal formShowType As FormShowConstants)    If formShowType <> vbModal Then formShowType = vbModeless 'Restrict value    m_showType = formShowTypeEnd Property'==============================================================================='Enables/disables the time labels'===============================================================================Public Property Get ShowTime() As Boolean    ShowTime = m_showTimeEnd PropertyPublic Property Let ShowTime(ByVal displayTime As Boolean)    m_showTime = displayTime    m_elapsed.Visible = m_showTime    m_remaining.Visible = m_showTime    RefreshEnd Property'==============================================================================='Indicates if the X button on the progress form was pressed'===============================================================================Public Property Get WasCancelled() As Boolean    WasCancelled = m_cancelledEnd Property'==============================================================================='Vertical position'===============================================================================Public Property Get Top() As Single    Top = m_form.TopEnd PropertyPublic Property Let Top(ByVal topValue As Single)    m_form.Top = topValue    m_isAutoCentered = FalseEnd Property'==============================================================================='Horizontal position'===============================================================================Public Property Get Left() As Single    Left = m_form.LeftEnd PropertyPublic Property Let Left(ByVal leftValue As Single)    m_form.Left = leftValue    m_isAutoCentered = FalseEnd Property'*******************************************************************************'Utility for positioning'*******************************************************************************Public Sub CenterOnApplication()    If Application.WindowState = xlMinimized Then Exit Sub    '    Dim leftPosition As Single    Dim topPosition As Single    '    With Application        leftPosition = .Left + (.Width - m_form.Width) / 2        If leftPosition < .Left Then leftPosition = .Left        '        topPosition = .Top + (.Height - m_form.Height) / 2        If topPosition < .Top Then topPosition = .Top    End With    With m_form        .StartUpPosition = 0        .Left = leftPosition        .Top = topPosition    End With    m_isAutoCentered = TrueEnd Sub'==============================================================================='Size'===============================================================================Public Property Get Height() As Single    Height = m_form.HeightEnd PropertyPublic Property Get Width() As Single    Width = m_form.WidthEnd PropertyPublic Property Let Width(ByVal widthValue As Single)    Const minWidth As Single = 180    Const maxWidth As Single = 450    Dim finalWidth As Single: finalWidth = widthValue    Dim offsetValue As Single    '    If finalWidth < minWidth Then finalWidth = minWidth    If finalWidth > maxWidth Then finalWidth = maxWidth    If finalWidth = m_form.Width Then Exit Property    offsetValue = finalWidth - m_form.Width    '    m_form.Width = finalWidth    m_barFrame.Width = m_barFrame.Width + offsetValue    m_percent.Left = m_percent.Left + offsetValue    If m_isAutoCentered Then m_form.Left = m_form.Left - offsetValue / 2End Property'*******************************************************************************'Self-instance'*******************************************************************************Public Function Self() As ProgressBar    Set Self = MeEnd Function'==============================================================================='Current progress value'===============================================================================Public Property Get Value() As Double    Value = m_currentValueEnd PropertyPublic Property Let Value(ByVal percentValue As Double)    If percentValue < 0 Or percentValue > 1 Then Exit Property    m_currentValue = percentValue    '    m_bar.Width = m_currentValue * m_barFrame.InsideWidth    m_percent.Caption = "Done: " & Format$(m_currentValue, "0%")    '    RefreshEnd Property'*******************************************************************************'Updates the time and allows for events so that the form is updated visually'*******************************************************************************Private Sub Refresh()    If m_isRunning Then        UpdateTime        DoEvents    End IfEnd SubPrivate Sub UpdateTime()    If Not m_showTime Then Exit Sub    If m_currentValue = 0 Then        m_elapsed.Caption = vbNullString        m_remaining.Caption = vbNullString        Exit Sub    End If    '    Dim elapsedTime As Date    Dim remainingTime As Date    '    elapsedTime = VBA.Now - m_startTime    remainingTime = elapsedTime / m_currentValue * (1 - m_currentValue)    '    UpdateTimeLabel m_elapsed, elapsedTime, "Elapsed time: "    UpdateTimeLabel m_remaining, remainingTime, "Remaining time: "End SubPrivate Sub UpdateTimeLabel(ByVal labelControl As MSForms.Label _                          , ByVal timeValue As Date _                          , ByVal prefix As String)    Dim labelValue As String: labelValue = prefix    If timeValue > 1 Then labelValue = labelValue & Int(CDbl(timeValue)) & "d "    labelControl.Caption = labelValue & Format$(timeValue, "hh:mm:ss")End Sub'*******************************************************************************'Runs a macro in a standard module'*******************************************************************************Public Function RunMacro(ByVal targetBook As Workbook _                       , ByVal procedure As String _                       , ParamArray args() As Variant) As Variant    If m_isRunning Then Exit Function    Dim methodName As String: methodName = TypeName(Me) & ".RunMacro"    '    If procedure = vbNullString Then        Err.Raise 5, methodName, "Invalid procedure name"    ElseIf targetBook Is Nothing Then        Err.Raise 91, methodName, "Workbook not set"    ElseIf UBound(args) >= LBound(args) Then 'Save arguments for async use        CloneParamArray args(0), UBound(args) + 1, m_args 'ByRef is preserved!    Else        m_args = Array()    End If    '    LetSet(RunMacro) = Run(procedure, targetBook, Nothing)End Function'*******************************************************************************'Runs a method of a given object'*******************************************************************************Public Function RunObjMethod(ByVal targetObject As Object _                           , ByVal procedure As String _                           , ParamArray args() As Variant) As Variant    If m_isRunning Then Exit Function    Dim methodName As String: methodName = TypeName(Me) & ".RunObjMethod"    '    If procedure = vbNullString Then        Err.Raise 5, methodName, "Invalid procedure name"    ElseIf targetObject Is Nothing Then        Err.Raise 91, methodName, "Object not set"    ElseIf UBound(args) >= LBound(args) Then 'Save arguments for async use        CloneParamArray args(0), UBound(args) + 1, m_args 'ByRef is preserved!    Else        m_args = Array()    End If    '    LetSet(RunObjMethod) = Run(procedure, Nothing, targetObject)End Function'*******************************************************************************'Runs a method:'   - in a standard module if 'targetBook' is provided'   - on an object if 'targetObject' is provided'*******************************************************************************Private Function Run(ByVal procedure As String _                   , ByVal targetBook As Workbook _                   , ByVal targetObject As Object) As Variant    m_procedure = procedure    Set m_targetBook = targetBook    Set m_targetObj = targetObject    '    m_isRunning = True    m_cancelled = False    Value = 0    '    m_form.Show m_showType    If m_showType = vbModeless Then        RunProcedure    Else 'vbModal. RunProcedure was already executed via Form_Activate event    End If    LetSet(Run) = m_resultEnd Function'*******************************************************************************'Utility - assigns a variant to another variant'*******************************************************************************Private Property Let LetSet(ByRef result As Variant, ByRef v As Variant)    If IsObject(v) Then Set result = v Else result = vEnd Property'*******************************************************************************'Runs the actual method'*******************************************************************************Private Sub RunProcedure()    m_startTime = Now()    '    Dim cKey As XlEnableCancelKey: cKey = Application.EnableCancelKey    If cKey <> xlDisabled Then Application.EnableCancelKey = xlDisabled    '    On Error GoTo Clean    If m_targetObj Is Nothing Then        RunOnBook    Else        #If Mac Then            RunOnObject m_args        #Else            LetSet(m_result) = rtcCallByName(targetObj:=m_targetObj _                                           , procNamePtr:=StrPtr(m_procedure) _                                           , vCallType:=VbMethod _                                           , args:=m_args)        #End If    End IfClean:    If cKey <> xlDisabled Then Application.EnableCancelKey = cKey    m_isRunning = False    If Err.Number = 0 Then        TryHideForm 'Protection if multiple progress bars are displayed    Else        m_form.Hide        Err.Raise Err.Number, TypeName(Me) & ".RunProcedure"    End IfEnd SubPrivate Sub RunOnBook(Optional ByVal Missing As Variant)    Const maxRunArgs As Long = 30    Dim argsCount As Long: argsCount = UBound(m_args) + 1    Dim i As Long    '    ReDim Preserve m_args(0 To maxRunArgs - 1)    For i = argsCount To UBound(m_args)        m_args(i) = Missing    Next i    '    LetSet(m_result) = Application.Run(FullProcedureName() _        , m_args(0), m_args(1), m_args(2), m_args(3), m_args(4) _        , m_args(5), m_args(6), m_args(7), m_args(8), m_args(9) _        , m_args(10), m_args(11), m_args(12), m_args(13), m_args(14) _        , m_args(15), m_args(16), m_args(17), m_args(18), m_args(19) _        , m_args(20), m_args(21), m_args(22), m_args(23), m_args(24) _        , m_args(25), m_args(26), m_args(27), m_args(28), m_args(29))End SubPrivate Function FullProcedureName() As String    FullProcedureName = "'" & m_targetBook.Name & "'!" & m_procedureEnd Function#If Mac ThenPrivate Sub RunOnObject(ByRef args() As Variant)    Dim o As Object: Set o = m_targetObj    Dim p As String: p = m_procedure    Dim v As VbCallType: v = VbMethod    '    Select Case UBound(args) - LBound(args) + 1    Case 0: LetSet(m_result) = CallByName(o, p, v)    Case 1: LetSet(m_result) = CallByName(o, p, v, args(0))    Case 2: LetSet(m_result) = CallByName(o, p, v, args(0), args(1))    Case 3: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2))    Case 4: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3))    Case 5: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4))    Case 6: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5))    Case 7: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6))    Case 8: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7))    Case 9: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8))    Case 10: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9))    Case 11: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10))    Case 12: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11))    Case 13: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12))    Case 14: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13))    Case 15: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14))    Case 16: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15))    Case 17: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16))    Case 18: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17))    Case 19: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18))    Case 20: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19))    Case 21: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20))    Case 22: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21))    Case 23: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22))    Case 24: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23))    Case 25: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24))    Case 26: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25))    Case 27: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26))    Case 28: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26), args(27))    Case 29: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26), args(27), args(28))    Case Else: LetSet(m_result) = CallByName(o, p, v, args(0), args(1), args(2), args(3), args(4), args(5), args(6), args(7), args(8), args(9), args(10), args(11), args(12), args(13), args(14), args(15), args(16), args(17), args(18), args(19), args(20), args(21), args(22), args(23), args(24), args(25), args(26), args(27), args(28), args(29))    End SelectEnd Sub#End If

Apologies to those who cannot stand big banners above method definitions. it's just my own preference.

Demo

Assuming a 'worker' code routine in a standard bas module:

Public Function DoWork(ByVal progress As ProgressBar, ByRef stepCount As Long) As Boolean    Dim i As Long    For i = 1 To stepCount        progress.Info2 = "Running " & i & " out of " & stepCount        progress.Value = i / stepCount        If progress.WasCancelled Then            'Clean-up code here            Exit Function        End If    Next    DoWork = TrueEnd Function

The call toRunMacro can be as simple as:

Public Sub ProgressBarTest()    With New ProgressBar        Debug.Print .RunMacro(ThisWorkbook, "DoWork", .Self, 2000)    End WithEnd Sub

Or, can be more customized:

Public Sub ProgressBarTest()    With New ProgressBar        .Info1 = "Please wait..."        .AllowCancel = True        .BarColor = &H4D6A00        .ShowTime = True        .ShowType = vbModeless        Debug.Print .RunMacro(ThisWorkbook, "DoWork", .Self, 2000)    End WithEnd Sub

enter image description here

If, we want to call a similar routine inClass1:

Public Function DoWork(ByVal progress As ProgressBar, ByRef stepCount As Long) As Boolean    Dim i As Long    For i = 1 To stepCount        progress.Info2 = "Running " & i & " out of " & stepCount        progress.Value = i / stepCount        If progress.WasCancelled Then Exit Function    Next    DoWork = TrueEnd Function

then we use theRunObjMethod method:

Public Sub ProgressBarTest()    With New ProgressBar        .Info1 = "Please wait..."        .AllowCancel = True        .BarColor = &H4D6A00        .ShowTime = True        .ShowType = vbModeless        Debug.Print .RunObjMethod(New Class1, "DoWork", .Self, 2000)    End WithEnd Sub

Misc

Here is a list of decisions I took and why:

  1. In both theRunMacro andRunObjMethod, the procedure name parameter is after the book/class object parameter so that the variable number of arguments follow nicely after the method name as it would in a regular call. Feels more natural than having the name first
  2. I have not fixed the position of the progress bar instance as a parameter for the 'worker' method. It can actually be omitted as an argument entirely but then the 'worker' would not be able to update the bar unless using a global variable - which is bad practice. Just wanted to have full flexibility for the user
  3. I did not want to have a global instance of theProgressBar class that has a factory. I did not consider it to be necessary.
  4. When callingApplication.Run I've made sure that I pass the maximum number of parameters (30) while making sure that the extra parameters are set to the special valueMissing so that I avoid a nasty longSelect Case
  5. On Windows, instead of callingCallByName I callrtcCallByName (defined on VBE7.dll) which allows me to pass the array of arguments as one argument. On Mac, unfortunately, I had to create a bigSelect Case (seeRunOnObject method). It would be great if someone knows a way to makertcCallByName work on a Mac or maybe another/better way to achieve the same result
  6. Running multipleRunMacro andRunObjMethod on the same instance works without the need to create a new instance. This could be useful when wanting to run consecutive 'workers' with the same options. Example:
Public Sub ProgressBarTest()    With New ProgressBar        .Info1 = "Please wait..."        .AllowCancel = True        .BarColor = &H4D6A00        .ShowTime = True        .ShowType = vbModal        Debug.Print .RunMacro(ThisWorkbook, "DoWork", .Self, 2000)        Debug.Print .RunObjMethod(New Class1, "DoWork", .Self, 2000)    End WithEnd Sub
  1. I did not group the class members into a private type because I wanted to preserve the PascalCase names of the exposed properties while all variables are camelCase. Grouping the members under a UDT makes naming so much more difficult unless you have everything in just PascalCase or just camelCase.

Any feedback and suggestions are welcome! Thank you!

Any future updates can be found atExcel-VBA-ProgressBar

askedFeb 4, 2022 at 16:38
Cristian Buse's user avatar
\$\endgroup\$
2
  • 4
    \$\begingroup\$I really like how you've taken my concept and pushed it to the next level, well done! And thanks for the kind words too!\$\endgroup\$CommentedFeb 4, 2022 at 22:21
  • 1
    \$\begingroup\$This is a great enhancement, its really useful how its able to run multiple procedures on the same ProgressBar instance. Also good how the Run function can take parameters. With the Reusable Progress Indicator I would refactor myprocedure into an object, put the parameters into a factory method and then pass the object to the ProgressIndicator create method:ProgressIndicator.Create("Run", Class1.Create(Param1, Param2))\$\endgroup\$CommentedFeb 20, 2022 at 9:29

0

You mustlog in to answer this question.

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.