加入 CodeStore VBA 模組

2026-08-18 00:39:40 +08:00
1 parent 9c5364f88e
commit 0e638bdd15
@@ -0,0 +1,101 @@
+Attribute VB_Name = "ProgressDialogue"
+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 * 10000) / 100 & "%"
+    runTime = GetRunTime()
+    If showTime Then lblRunTime.Caption = "Time Elapsed: " & GetRunTimeString(runTime, True)
+    If showTimeLeft And progress > 0 Then _
+        lblRemainingTime.Caption = "Est. Time Left: " & 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 & " hours ", "") _
+                     & IIf(mins > 0, mins & " minutes ", "") _
+                     & IIf(secs > 0, IIf(showMsecs, secs, Int(secs + 0.5)) & " seconds", "")
+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
+
+