Barra di avanzamento per le macro VBA in Excel

Option Explicit
 
Dim Cancelled As Boolean, showTime As Boolean, showTimeLeft As Boolean
Dim startTime As Long
Dim BarMin As Long, BarMax As Long, BarVal As Long
 
Private Declare PtrSafe Function GetTickCount Lib "Kernel32" () As Long
 
'Title will be the title of the dialogue.
'Status will be the label above the progress bar, and can be changed with SetStatus.
'Min is the progress bar minimum value, only set by calling configure.
'Max is the progress bar maximum value, only set by calling configure.
'CancelButtonText is the caption of the cancel button. If set to vbNullString, it is hidden.
'optShowTimeElapsed controls whether the progress bar computes and displays the time elapsed.
'optShowTimeRemaining controls whether the progress bar estimates and displays the time remaining.
'calling Configure sets the current value equal to Min.
'calling Configure resets the current run time.
Public Sub Configure(ByVal title As String, ByVal status As String, _
                     ByVal Min As Long, ByVal Max As Long, _
                     Optional ByVal CancelButtonText As String = "Cancel", _
                     Optional ByVal optShowTimeElapsed As Boolean = True, _
                     Optional ByVal optShowTimeRemaining As Boolean = True)
    Me.Caption = title
    lblStatus.Caption = status
    BarMin = Min
    BarMax = Max
    BarVal = Min
    CancelButton.Visible = Not CancelButtonText = vbNullString
    CancelButton.Caption = CancelButtonText
    startTime = GetTickCount
    showTime = optShowTimeElapsed
    showTimeLeft = optShowTimeRemaining
    lblRunTime.Caption = ""
    lblRemainingTime.Caption = ""
    Cancelled = False
End Sub
 
'Set the label text above the status bar
Public Sub SetStatus(ByVal status As String)
    lblStatus.Caption = status
    DoEvents
End Sub
 
'Set the value of the status bar, a long which is snapped to a value between Min and Max
Public Sub SetValue(ByVal value As Long)
    If value < BarMin Then value = BarMin
    If value > BarMax Then value = BarMax
    Dim progress As Double, runTime As Long
    BarVal = value
    progress = (BarVal - BarMin) / (BarMax - BarMin)
    ProgressBar.Width = 292 * progress
    lblPercent = Int(progress * 100) & "%"
    runTime = GetRunTime()
    If showTime Then lblRunTime.Caption = "Tempo Trascorso: " & GetRunTimeString(runTime, True)
    If showTimeLeft And progress > 0 Then _
        lblRemainingTime.Caption = "Tempo rimanente (stima): " & GetRunTimeString(runTime * (1 - progress) / progress, False)
    DoEvents
End Sub
 
'Get the time (in milliseconds) since the progress bar "Configure" routine was last called
Public Function GetRunTime() As Long
    GetRunTime = GetTickCount - startTime
End Function
 
'Get the time (in hours, minutes, seconds) since "Configure" was last called
Public Function GetFormattedRunTime() As String
    GetFormattedRunTime = GetRunTimeString(GetTickCount - startTime)
End Function
 
'Formats a time in milliseconds as hours, minutes, seconds.milliseconds
'Milliseconds are excluded if showMsecs is set to false
Private Function GetRunTimeString(ByVal runTime As Long, Optional ByVal showMsecs As Boolean = True) As String
    Dim msecs&, hrs&, mins&, secs#
    msecs = runTime
    hrs = Int(msecs / 3600000)
    mins = Int(msecs / 60000) - 60 * hrs
    secs = msecs / 1000 - 60 * (mins + 60 * hrs)
    GetRunTimeString = IIf(hrs > 0, hrs & " ore ", "") _
                     & IIf(mins > 0, mins & " minuti ", "") _
                     & IIf(secs > 0, IIf(showMsecs, secs, Int(secs + 0.5)) & " secondi", "")
End Function
 
'Returns the current value of the progress bar
Public Function GetValue() As Long
    GetValue = BarVal
End Function
 
'Returns whether or not the cancel button has been pressed.
'The ProgressDialogue must be polled regularily to detect whether cancel was pressed.
Public Function cancelIsPressed() As Boolean
    cancelIsPressed = Cancelled
End Function
 
'Recalls that cancel was pressed so that they calling routine can be notified next time it asks.
Private Sub CancelButton_Click()
    Cancelled = True
    lblStatus.Caption = "Cancelled By User. Please Wait."
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Cancelled = True
    lblStatus.Caption = "Cancelled By User. Please Wait."
End Sub

Sub Test()
    Dim i As Long
    Dim diag As New ProgressDialogue
    diag.Configure "Test Avanzamento", "Sto avanzando...", -10000, 10000
    diag.Show
    For i = -10000 To 10000
        diag.SetValue i
        diag.SetStatus "Sto avanzando... " & i
        On Error Resume Next
        If diag.cancelIsPressed Then Exit For
        On Error GoTo 0
    Next i
    diag.Hide
End Sub