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

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