How to: Animation (triple dot) on progress bar during working macro

Question

I have a progress bar, which is showing progress in percentage and on 'animated' rectangle.

I know how to show the progress of the macro based on "marks" in code, that's not the case. Example of code called as that "mark" in code to change the percentage on progress bar:

Sub progress(pctCompl As Long)

 Progression.Text.Caption = pctCompl & "% Completed"
 Progression.Bar.Width = pctCompl * 2

 DoEvents 'update the userform

End Sub

I wonder if it's possible to do additional animation behind "Please wait" on that progress bar - triple dot:1 dot, 1 second pause, 2 dots, 1 second pause, 3 dots, 1 second pause. This is 1 loop for that animation.

I was trying to do something, mostly I was achieving infinite loops or macro doing nothing but that triple dot animation, which was freezing Excel application.

Private Sub UserForm_Activate()

Do Until Progression.Bar.Width = 200
    Progression.Text2.Caption = "Please wait."
    Progression.Repaint
    Application.Wait Now + TimeValue("0:00:01")
    Progression.Text2.Caption = "Please wait.."
    Progression.Repaint
    Application.Wait (Now + TimeValue("0:00:01"))
    Progression.Text2.Caption = "Please wait..."
    Progression.Repaint
    Application.Wait (Now + TimeValue("0:00:01"))
Loop

End Sub

I thought it is good place to ask that kind of questions - is it possible and if yes how to achieve that?

Answer 1

I sometimes have an image that I like to 'animate' on a UserForm as a progress indicator, and I use the Win API timer for that. The code below may be a little 'overkill' for your needs, as image changes need to be triggered either by an event or by Repaint, the latter of which can cause flicker. I believe Labels update as soon as the property value changes. If this is the case then you could leave out the listener class shown below and adjust the code accordingly.

With the above caveat, a skeleton implementation could look like this:

Userform code

Note: my userform has a start button, a stop button and one label, called lblWait.

Option Explicit

Private WithEvents mTimerListener As cTimerListener

Private Sub btnStart_Click()
    HandleStartTimer mTimerListener
End Sub

Private Sub btnStop_Click()
    HandleStopTimer
End Sub

Private Sub mTimerListener_DotCountIncremented(count As Long)
    Me.lblWait = "Please wait" & String(count, ".")
End Sub

Private Sub UserForm_Initialize()
    Set mTimerListener = New cTimerListener
End Sub

Class code

Note: I've called this class cTimerListener.

Option Explicit

Public Event DotCountIncremented(count As Long)

Private mDotCount As Long

Public Property Let DotCount(RHS As Long)
    mDotCount = RHS
    If mDotCount > 3 Then mDotCount = 0
    RaiseEvent DotCountIncremented(mDotCount)
    DoEvents
End Property

Public Property Get DotCount() As Long
    DotCount = mDotCount
End Property

And Module code

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function SetTimer Lib "user32" ( _
        ByVal HWnd As LongPtr, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As LongPtr) As Long

    Private Declare PtrSafe Function KillTimer Lib "user32" ( _
        ByVal HWnd As LongPtr, _
        ByVal nIDEvent As Long) As Long

#Else
    Private Declare Function SetTimer Lib "user32" ( _
        ByVal HWnd As Long, _
        ByVal nIDEvent As Long, _
        ByVal uElapse As Long, _
        ByVal lpTimerFunc As Long) As Long

    Private Declare Function KillTimer Lib "user32" ( _
        ByVal HWnd As Long, _
        ByVal nIDEvent As Long) As Long
#End If

Private mTimerId As Long
Private mTimerListener As cTimerListener

Public Sub HandleStartTimer(timerListener As cTimerListener)
    Set mTimerListener = timerListener
    #If VBA7 Then
        mTimerId = SetTimer(0&, 0&, 0.5 * 1000, AddressOf TimerProc64)
    #Else
        mTimerId = SetTimer(0&, 0&, 0.5 * 1000, AddressOf TimerProc32)
    #End If
End Sub

Public Sub HandleStopTimer()
    KillTimer 0&, mTimerId
End Sub

#If VBA7 Then
    Private Sub TimerProc64(ByVal HWnd As LongPtr, ByVal uMsg As Long, _
        ByVal nIDEvent As Long, ByVal dwTimer As Long)

        TimerProc
    End Sub
#Else
    Private Sub TimerProc32(ByVal HWnd As Long, ByVal uMsg As Long, _
        ByVal nIDEvent As Long, ByVal dwTimer As Long)

        TimerProc
    End Sub
#End If

Private Sub TimerProc()
    If Not mTimerListener Is Nothing Then
        With mTimerListener
            .DotCount = .DotCount + 1
        End With
    End If
End Sub