ms-access 中的 "progress bar" 表单在其属性从模块中的循环更改时不会更新
A "progress bar" Form in ms-access will not update when its properties are changed from a loop in a module
我试图在我的访问数据库中从 "Document Control Process" excel 工作簿中导入大量数据时显示一个对话框表单，或者更确切地说是一个 dialog-looking 表单获取每个月的更新。导入最多需要 15 分钟，所以我想向用户显示一个进度对话框，显示正在发生的事情，以及一个按钮，如果他愿意，可以在结束前中断该过程（这对调试我的程序也非常有用）。
我有一个正常的模块，其中一个程序显示表单并设置它的当前属性（标题、解释当前操作的标签的标题、进度条，在这种情况下是两个标签，我调整了标题和尺寸）。然后它启动循环以导入每个文档，并在每次迭代中更新表单以显示进度。
除了表格显示外，标题被设置然后冻结，直到15分钟后整个信息被导入。我曾尝试在模块中添加一些 DoEvents（甚至在前几个不起作用时添加了很多）但无济于事。
以前有人遇到过这个问题并且可以帮助我吗？我已经在 Stack Overflow 和网上更广泛地寻找它好几天了，但这个特定问题似乎从未被引用过......我的意思是进度对话框有很多解决方案，但似乎永远不会受到影响更新问题，而我每次都被它击中。我怀疑与线程相关的问题，但我无法固定它。
现在我终于找到了一种方法来显示可以从任何地方调用并且不会冻结的通用进度对话框。
感谢 SunKnight0 的评论让我走上了正确的道路，感谢 Adams Tips 对问题 "Progress bar in in ms-access" 的回答。
下面的描述有点冗长，但我认为它提供了实现进度对话框所需的一切。
这就是诀窍。我包含了完整的解决方案，因此您只需复制模块中的代码即可使其正常工作。该对话框显示当前正在执行的操作的详细信息，指示经过的时间和剩余处理时间的估计，并提供一种在需要时在结束前完全中断进程的方法（在调试进程时也很方便）。
解决方案由一个窗体组成，这里叫做FrmProgress，还有一个模块ModProgress。您可以从任何您想要的地方调用模块中的方法，就像您对 class 所做的那样，它会处理表单并确保它已更新且不会冻结。对于进度条本身，我使用 Adam 的 class clsLblProg，这里重命名为 CProgressLabel。这不是强制性的，但我喜欢这个结果。这是为 Access 制作的，但可以轻松导出到 Excel.
秘诀在于循环是在ModProgress中处理的，在模态窗体的线程中。在每次迭代中，模块调用一个在开始时给出名称的过程。最后，在关闭表单之前，模块可以调用另一个过程一次。我用它来显示一个消息框，重述已完成的工作，并在调试时显示已用的总时间。这两个过程是使用 Application.Run 调用的，因此它们需要在普通模块中，而不是在表单或 class 模块中。
使用方法：
'this starts the progress popup as modal, so we are pass this line only when the progress is completed and the popup closed
ModProgress.ProgressStart nbIteration, "Importing Dcp...", "Starting import...", "DcpImportUnit", "DcpImportStop", True, True
这将启动 nbIteration 循环的进度对话框，标题为 "Importing Dcp..."，初始消息为 "Starting import..."。在每次迭代中，对话将调用 public 过程 "DcpImportUnit"，最后它将调用 public 过程 "DcpImportStop"。经过的时间将在每次迭代时显示和更新。剩余时间将在每次迭代时显示和更新。
您需要一个设计如下的表单（此处称为 FrmProgress）：
在设计模式下，将窗体的Pop Up属性设置为Yes，Modal属性设置为No。没有进度条是正常的，因为CProgressLabel使用了LblBack、LblFront和LblCaption 在运行时制作一个。
表单代码如下：
Option Compare Database
Option Explicit
Private Sub CmdStop_Click()
ModProgress.ProgressStop
End Sub
Private Sub Form_Load()
Me.TimerInterval = 200
Me.LblBack.Caption = " "
ModProgress.ProgressInitiate LblBack, LblFront, LblCaption, LblTitle, LblMessage, LblElapsed, LblRemaining
End Sub
Private Sub Form_Timer()
Me.TimerInterval = 0
ModProgress.ProgressRun
End Sub
然后是来自 Adam 的漂亮 class，几乎没有任何修改（我只是用 RGB 替换了 Update 方法中的直接颜色值，我发现更清楚）：
Option Compare Database
Option Explicit
' By Adam Waller
' Last Modified: 12/16/05
'Private Const sngOffset As Single = 1.5 ' For Excel
Private Const sngOffset As Single = 15 ' For Access
Private mdblMax As Double ' max value of progress bar
Private mdblVal As Double ' current value of progress bar
Private mdblFullWidth As Double ' width of front label at 100%
Private mdblIncSize As Double
Private mblnHideCap As Boolean ' display percent complete
Private mobjParent As Object ' parent of back label
Private mlblBack As Access.Label ' existing label for back
Private mlblFront As Access.Label ' label created for front
Private mlblCaption As Access.Label ' progress bar caption
Private mdteLastUpdate As Date ' Time last updated
Private mblnNotSmooth As Boolean ' Display smooth bar by doevents after every update.
' This class displays a progress bar created
' from 3 labels.
' to use, just add a label to your form,
' and use this back label to position the
' progress bar.
Public Sub Initialize(BackLabel As Access.Label, FrontLabel As Access.Label, CaptionLabel As Access.Label)
On Error GoTo 0 ' Debug Mode
Dim objParent As Object ' could be a form or tab control
Dim frm As Form
Set mobjParent = BackLabel.Parent
' set private variables
Set mlblBack = BackLabel
Set mlblFront = FrontLabel
Set mlblCaption = CaptionLabel
' set properties for back label
With mlblBack
.Visible = True
.SpecialEffect = 2 ' sunken. Seems to lose when not visible.
End With
' set properties for front label
With mlblFront
mdblFullWidth = mlblBack.Width - (sngOffset * 2)
.Left = mlblBack.Left + sngOffset
.Top = mlblBack.Top + sngOffset
.Width = 0
.Height = mlblBack.Height - (sngOffset * 2)
.Caption = ""
.BackColor = 8388608
.BackStyle = 1
.Visible = True
End With
' set properties for caption label
With mlblCaption
.Left = mlblBack.Left + 2
.Top = mlblBack.Top + 2
.Width = mlblBack.Width - 4
.Height = mlblBack.Height - 4
.TextAlign = 2 'fmTextAlignCenter
.BackStyle = 0 'fmBackStyleTransparent
.Caption = "0%"
.Visible = Not Me.HideCaption
.ForeColor = 16777215 ' white
End With
'Stop
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Initialize", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Private Sub Class_Terminate()
On Error GoTo 0 ' Debug Mode
On Error Resume Next
mlblFront.Visible = False
mlblCaption.Visible = False
On Error GoTo 0 ' Debug Mode
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Class_Terminate", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Public Property Get Max() As Double
On Error GoTo 0 ' Debug Mode
Max = mdblMax
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Max", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let Max(ByVal dblMax As Double)
On Error GoTo 0 ' Debug Mode
mdblMax = dblMax
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Max", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Get Value() As Double
On Error GoTo 0 ' Debug Mode
Value = mdblVal
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Value", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let Value(ByVal dblVal As Double)
On Error GoTo 0 ' Debug Mode
'update only if change is => 1%
If (CInt(dblVal * (100 / mdblMax))) > (CInt(mdblVal * (100 / mdblMax))) Then
mdblVal = dblVal
Update
Else
mdblVal = dblVal
End If
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Value", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Get IncrementSize() As Double
On Error GoTo 0 ' Debug Mode
IncrementSize = mdblIncSize
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "IncrementSize", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let IncrementSize(ByVal dblSize As Double)
On Error GoTo 0 ' Debug Mode
mdblIncSize = dblSize
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "IncrementSize", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Get HideCaption() As Boolean
On Error GoTo 0 ' Debug Mode
HideCaption = mblnHideCap
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "HideCaption", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let HideCaption(ByVal blnHide As Boolean)
On Error GoTo 0 ' Debug Mode
mblnHideCap = blnHide
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "HideCaption", Erl
Resume Next ' Resume at next line.
End Select
End Property
Private Sub Update()
On Error GoTo 0 ' Debug Mode
Dim intPercent As Integer
Dim dblWidth As Double
'On Error Resume Next
intPercent = mdblVal * (100 / mdblMax)
dblWidth = mdblVal * (mdblFullWidth / mdblMax)
mlblFront.Width = dblWidth
mlblCaption.Caption = intPercent & "%"
'mlblFront.Parent.Repaint ' may not be needed
' Use white or black, depending on progress
If Me.Value > (Me.Max / 2) Then
mlblCaption.ForeColor = RGB(255, 255, 255) ' white
Else
mlblCaption.ForeColor = RGB(0, 0, 0) ' black
End If
If mblnNotSmooth Then
If mdteLastUpdate <> Now Then
' update every second.
DoEvents
mdteLastUpdate = Now
End If
Else
DoEvents
End If
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Update", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Public Sub Increment()
On Error GoTo 0 ' Debug Mode
Dim dblVal As Double
dblVal = Me.Value
If dblVal < Me.Max Then
Me.Value = dblVal + 1
'Call Update
End If
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Increment", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Public Sub Clear()
On Error GoTo 0 ' Debug Mode
Call Class_Terminate
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Clear", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Private Function ParentForm(ctlControl As Control) As String
' returns the name of the parent form
Dim objParent As Object
Set objParent = ctlControl
Do While Not TypeOf objParent Is Form
Set objParent = objParent.Parent
Loop
' Now we should have the parent form
ParentForm = objParent.Name
End Function
Public Property Get Smooth() As Boolean
' Display the progress bar smoothly.
' True by default, this property allows the call
' to doevents after every increment.
' If False, it will only update once per second.
' (This may increase speed for fast progresses.)
'
' negative to set default to true
Smooth = mblnNotSmooth
End Property
Public Property Let Smooth(ByVal IsSmooth As Boolean)
mblnNotSmooth = Not IsSmooth
End Property
Private Sub LogErr(objErr, strMod, strProc, intLine)
' For future use.
End Sub
现在模块 ModProgress 将所有内容链接在一起：
Option Compare Database
Option Explicit
Private mStop As Boolean
Private mMax As Long
Private mTitleString As String
Private mMessageString As String
Private mProcCall As String
Private mProcStop As String
Private mWithTimeElapsed As Boolean
Private mWithTimeRemaining As Boolean
Private mTitle As Access.Label
Private mMessage As Access.Label
Private mPgr As CProgressLabel
Private mElapsed As Access.Label
Private mRemaining As Access.Label
Private mDateStart As Date
Private mCount As Long
Public Property Get Message() As String
If mMessage Is Nothing Then
Message = ""
Else
Message = mMessage.Caption
End If
End Property
Public Property Let Message(msg As String)
If Not mMessage Is Nothing Then
mMessage.Caption = msg
End If
End Property
Public Sub ProgressInitiate(BackLabel As Access.Label, FrontLabel As Access.Label, CaptionLabel As Access.Label, TitleLabel As Access.Label, MessageLabel As Access.Label, ElapsedLabel As Access.Label, RemainingLabel As Access.Label)
Set mTitle = TitleLabel
Set mMessage = MessageLabel
Set mPgr = New CProgressLabel
Set mElapsed = ElapsedLabel
Set mRemaining = RemainingLabel
mTitle.Caption = mTitleString
Message = mMessageString
With mPgr
.Initialize BackLabel, FrontLabel, CaptionLabel
.Max = mMax
End With
mElapsed.Visible = mWithTimeElapsed
mRemaining.Visible = mWithTimeRemaining
ProcWait
End Sub
Private Sub ProcRun(callProc As String)
If callProc <> "" Then Application.Run callProc
End Sub
Private Sub ProcWait(Optional waitingTime As Single = 0.1)
Dim sgTimer As Single
sgTimer = Timer
Do While Timer < sgTimer + waitingTime
DoEvents
Loop
End Sub
Public Function ProgressCount() As Long
ProgressCount = mCount
End Function
Public Function ProgressStop() As Long
mStop = True
ProgressStop = mCount
End Function
Public Sub ProgressRun()
For mCount = 0 To mPgr.Max
'this allow to either interrupt the loop before the end or
'or just runthe next iteration by calling the procedure given by the caller in ProgressStart
If mStop Then
ProcRun mProcStop
Exit For
Else
If mWithTimeElapsed Then mElapsed.Caption = "Time elapsed: " & TimeElapsed
If mWithTimeRemaining Then mRemaining.Caption = "Estimated time remaining: " & TimeRemaining
If True Then
ProcRun mProcCall
Else
Message = "Loop nr " & CStr(mCount)
End If
End If
mPgr.Increment
'leave the time for the application to manage the display of the popup after each update
ProcWait
Next mCount
If mCount > mPgr.Max Then ProcRun mProcStop 'runs the possible stop procedure if we reach the limit set for the loop execution
DoCmd.Close acForm, "FrmProgress", acSaveNo 'this is the only place where we close the form
End Sub
Public Sub ProgressStart(vMax As Long, sTitle As String, sMessage As String, callProc As String, Optional callStop As String = "", Optional withTimeElapsed As Boolean = False, Optional withTimeRemaining As Boolean = True)
mMax = vMax
mStop = False
mTitleString = sTitle 'this only store the title in a variable so far, it will be set on the label in ProgressRun
mMessageString = sMessage 'this only store the title in a variable so far, it will be set on the label in ProgressRun
mProcCall = callProc
mProcStop = callStop
mWithTimeRemaining = withTimeRemaining
mWithTimeElapsed = withTimeElapsed
mDateStart = Now
'the next line opens the form, and its Load event will call this
'module's ProgressRun procedure to start the whole shenanigan
'it also only in ProgressRun that the form is closed
DoCmd.OpenForm "FrmProgress"
End Sub
Public Sub ProgressUpdate(newMessage As String)
mMessage.Caption = newMessage
End Sub
Public Property Get TimeElapsed() As String
TimeElapsed = TimeToString(Now - mDateStart)
End Property
Public Property Get TimeRemaining() As String
Dim iCount As Integer
Dim dt As Date
'we wait a few cycles to have a significant time reference
If mCount < 5 Then
TimeRemaining = ""
Else
dt = Now - mDateStart
TimeRemaining = TimeToString(dt * ((mPgr.Max / mCount) - 1))
End If
End Property
Private Function TimeToString(dt As Date) As String
Dim intHours As Long
Dim intMinutes As Long
' Calculate the time interval
intHours = Int(CSng(dt * 24))
intMinutes = Int(CSng(dt * 24 * 60)) - intHours * 60
' Format and print the time interval in hours, minutes and seconds.
If intHours > 0 Then TimeToString = intHours & "h"
If intMinutes > 0 Then TimeToString = TimeToString & intMinutes & "min"
TimeToString = TimeToString & Format(dt, "ss") & "s"
End Function
就是这样！将此代码复制到您的模块中，一切都会顺利进行。
祝大家编码愉快。
我试图在我的访问数据库中从 "Document Control Process" excel 工作簿中导入大量数据时显示一个对话框表单，或者更确切地说是一个 dialog-looking 表单获取每个月的更新。导入最多需要 15 分钟，所以我想向用户显示一个进度对话框，显示正在发生的事情，以及一个按钮，如果他愿意，可以在结束前中断该过程（这对调试我的程序也非常有用）。
我有一个正常的模块，其中一个程序显示表单并设置它的当前属性（标题、解释当前操作的标签的标题、进度条，在这种情况下是两个标签，我调整了标题和尺寸）。然后它启动循环以导入每个文档，并在每次迭代中更新表单以显示进度。
除了表格显示外，标题被设置然后冻结，直到15分钟后整个信息被导入。我曾尝试在模块中添加一些 DoEvents（甚至在前几个不起作用时添加了很多）但无济于事。
以前有人遇到过这个问题并且可以帮助我吗？我已经在 Stack Overflow 和网上更广泛地寻找它好几天了，但这个特定问题似乎从未被引用过......我的意思是进度对话框有很多解决方案，但似乎永远不会受到影响更新问题，而我每次都被它击中。我怀疑与线程相关的问题，但我无法固定它。
现在我终于找到了一种方法来显示可以从任何地方调用并且不会冻结的通用进度对话框。 感谢 SunKnight0 的评论让我走上了正确的道路，感谢 Adams Tips 对问题 "Progress bar in in ms-access" 的回答。
下面的描述有点冗长，但我认为它提供了实现进度对话框所需的一切。
这就是诀窍。我包含了完整的解决方案，因此您只需复制模块中的代码即可使其正常工作。该对话框显示当前正在执行的操作的详细信息，指示经过的时间和剩余处理时间的估计，并提供一种在需要时在结束前完全中断进程的方法（在调试进程时也很方便）。
解决方案由一个窗体组成，这里叫做FrmProgress，还有一个模块ModProgress。您可以从任何您想要的地方调用模块中的方法，就像您对 class 所做的那样，它会处理表单并确保它已更新且不会冻结。对于进度条本身，我使用 Adam 的 class clsLblProg，这里重命名为 CProgressLabel。这不是强制性的，但我喜欢这个结果。这是为 Access 制作的，但可以轻松导出到 Excel.
秘诀在于循环是在ModProgress中处理的，在模态窗体的线程中。在每次迭代中，模块调用一个在开始时给出名称的过程。最后，在关闭表单之前，模块可以调用另一个过程一次。我用它来显示一个消息框，重述已完成的工作，并在调试时显示已用的总时间。这两个过程是使用 Application.Run 调用的，因此它们需要在普通模块中，而不是在表单或 class 模块中。
使用方法：
'this starts the progress popup as modal, so we are pass this line only when the progress is completed and the popup closed
ModProgress.ProgressStart nbIteration, "Importing Dcp...", "Starting import...", "DcpImportUnit", "DcpImportStop", True, True
这将启动 nbIteration 循环的进度对话框，标题为 "Importing Dcp..."，初始消息为 "Starting import..."。在每次迭代中，对话将调用 public 过程 "DcpImportUnit"，最后它将调用 public 过程 "DcpImportStop"。经过的时间将在每次迭代时显示和更新。剩余时间将在每次迭代时显示和更新。
您需要一个设计如下的表单（此处称为 FrmProgress）：
在设计模式下，将窗体的Pop Up属性设置为Yes，Modal属性设置为No。没有进度条是正常的，因为CProgressLabel使用了LblBack、LblFront和LblCaption 在运行时制作一个。
表单代码如下：
Option Compare Database
Option Explicit
Private Sub CmdStop_Click()
ModProgress.ProgressStop
End Sub
Private Sub Form_Load()
Me.TimerInterval = 200
Me.LblBack.Caption = " "
ModProgress.ProgressInitiate LblBack, LblFront, LblCaption, LblTitle, LblMessage, LblElapsed, LblRemaining
End Sub
Private Sub Form_Timer()
Me.TimerInterval = 0
ModProgress.ProgressRun
End Sub
然后是来自 Adam 的漂亮 class，几乎没有任何修改（我只是用 RGB 替换了 Update 方法中的直接颜色值，我发现更清楚）：
Option Compare Database
Option Explicit
' By Adam Waller
' Last Modified: 12/16/05
'Private Const sngOffset As Single = 1.5 ' For Excel
Private Const sngOffset As Single = 15 ' For Access
Private mdblMax As Double ' max value of progress bar
Private mdblVal As Double ' current value of progress bar
Private mdblFullWidth As Double ' width of front label at 100%
Private mdblIncSize As Double
Private mblnHideCap As Boolean ' display percent complete
Private mobjParent As Object ' parent of back label
Private mlblBack As Access.Label ' existing label for back
Private mlblFront As Access.Label ' label created for front
Private mlblCaption As Access.Label ' progress bar caption
Private mdteLastUpdate As Date ' Time last updated
Private mblnNotSmooth As Boolean ' Display smooth bar by doevents after every update.
' This class displays a progress bar created
' from 3 labels.
' to use, just add a label to your form,
' and use this back label to position the
' progress bar.
Public Sub Initialize(BackLabel As Access.Label, FrontLabel As Access.Label, CaptionLabel As Access.Label)
On Error GoTo 0 ' Debug Mode
Dim objParent As Object ' could be a form or tab control
Dim frm As Form
Set mobjParent = BackLabel.Parent
' set private variables
Set mlblBack = BackLabel
Set mlblFront = FrontLabel
Set mlblCaption = CaptionLabel
' set properties for back label
With mlblBack
.Visible = True
.SpecialEffect = 2 ' sunken. Seems to lose when not visible.
End With
' set properties for front label
With mlblFront
mdblFullWidth = mlblBack.Width - (sngOffset * 2)
.Left = mlblBack.Left + sngOffset
.Top = mlblBack.Top + sngOffset
.Width = 0
.Height = mlblBack.Height - (sngOffset * 2)
.Caption = ""
.BackColor = 8388608
.BackStyle = 1
.Visible = True
End With
' set properties for caption label
With mlblCaption
.Left = mlblBack.Left + 2
.Top = mlblBack.Top + 2
.Width = mlblBack.Width - 4
.Height = mlblBack.Height - 4
.TextAlign = 2 'fmTextAlignCenter
.BackStyle = 0 'fmBackStyleTransparent
.Caption = "0%"
.Visible = Not Me.HideCaption
.ForeColor = 16777215 ' white
End With
'Stop
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Initialize", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Private Sub Class_Terminate()
On Error GoTo 0 ' Debug Mode
On Error Resume Next
mlblFront.Visible = False
mlblCaption.Visible = False
On Error GoTo 0 ' Debug Mode
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Class_Terminate", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Public Property Get Max() As Double
On Error GoTo 0 ' Debug Mode
Max = mdblMax
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Max", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let Max(ByVal dblMax As Double)
On Error GoTo 0 ' Debug Mode
mdblMax = dblMax
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Max", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Get Value() As Double
On Error GoTo 0 ' Debug Mode
Value = mdblVal
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Value", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let Value(ByVal dblVal As Double)
On Error GoTo 0 ' Debug Mode
'update only if change is => 1%
If (CInt(dblVal * (100 / mdblMax))) > (CInt(mdblVal * (100 / mdblMax))) Then
mdblVal = dblVal
Update
Else
mdblVal = dblVal
End If
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Value", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Get IncrementSize() As Double
On Error GoTo 0 ' Debug Mode
IncrementSize = mdblIncSize
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "IncrementSize", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let IncrementSize(ByVal dblSize As Double)
On Error GoTo 0 ' Debug Mode
mdblIncSize = dblSize
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "IncrementSize", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Get HideCaption() As Boolean
On Error GoTo 0 ' Debug Mode
HideCaption = mblnHideCap
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "HideCaption", Erl
Resume Next ' Resume at next line.
End Select
End Property
Public Property Let HideCaption(ByVal blnHide As Boolean)
On Error GoTo 0 ' Debug Mode
mblnHideCap = blnHide
Exit Property
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "HideCaption", Erl
Resume Next ' Resume at next line.
End Select
End Property
Private Sub Update()
On Error GoTo 0 ' Debug Mode
Dim intPercent As Integer
Dim dblWidth As Double
'On Error Resume Next
intPercent = mdblVal * (100 / mdblMax)
dblWidth = mdblVal * (mdblFullWidth / mdblMax)
mlblFront.Width = dblWidth
mlblCaption.Caption = intPercent & "%"
'mlblFront.Parent.Repaint ' may not be needed
' Use white or black, depending on progress
If Me.Value > (Me.Max / 2) Then
mlblCaption.ForeColor = RGB(255, 255, 255) ' white
Else
mlblCaption.ForeColor = RGB(0, 0, 0) ' black
End If
If mblnNotSmooth Then
If mdteLastUpdate <> Now Then
' update every second.
DoEvents
mdteLastUpdate = Now
End If
Else
DoEvents
End If
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Update", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Public Sub Increment()
On Error GoTo 0 ' Debug Mode
Dim dblVal As Double
dblVal = Me.Value
If dblVal < Me.Max Then
Me.Value = dblVal + 1
'Call Update
End If
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Increment", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Public Sub Clear()
On Error GoTo 0 ' Debug Mode
Call Class_Terminate
Exit Sub
ErrHandler:
Select Case Err.Number
Case Else
LogErr Err, "clsLblProg", "Clear", Erl
Resume Next ' Resume at next line.
End Select
End Sub
Private Function ParentForm(ctlControl As Control) As String
' returns the name of the parent form
Dim objParent As Object
Set objParent = ctlControl
Do While Not TypeOf objParent Is Form
Set objParent = objParent.Parent
Loop
' Now we should have the parent form
ParentForm = objParent.Name
End Function
Public Property Get Smooth() As Boolean
' Display the progress bar smoothly.
' True by default, this property allows the call
' to doevents after every increment.
' If False, it will only update once per second.
' (This may increase speed for fast progresses.)
'
' negative to set default to true
Smooth = mblnNotSmooth
End Property
Public Property Let Smooth(ByVal IsSmooth As Boolean)
mblnNotSmooth = Not IsSmooth
End Property
Private Sub LogErr(objErr, strMod, strProc, intLine)
' For future use.
End Sub
现在模块 ModProgress 将所有内容链接在一起：
Option Compare Database
Option Explicit
Private mStop As Boolean
Private mMax As Long
Private mTitleString As String
Private mMessageString As String
Private mProcCall As String
Private mProcStop As String
Private mWithTimeElapsed As Boolean
Private mWithTimeRemaining As Boolean
Private mTitle As Access.Label
Private mMessage As Access.Label
Private mPgr As CProgressLabel
Private mElapsed As Access.Label
Private mRemaining As Access.Label
Private mDateStart As Date
Private mCount As Long
Public Property Get Message() As String
If mMessage Is Nothing Then
Message = ""
Else
Message = mMessage.Caption
End If
End Property
Public Property Let Message(msg As String)
If Not mMessage Is Nothing Then
mMessage.Caption = msg
End If
End Property
Public Sub ProgressInitiate(BackLabel As Access.Label, FrontLabel As Access.Label, CaptionLabel As Access.Label, TitleLabel As Access.Label, MessageLabel As Access.Label, ElapsedLabel As Access.Label, RemainingLabel As Access.Label)
Set mTitle = TitleLabel
Set mMessage = MessageLabel
Set mPgr = New CProgressLabel
Set mElapsed = ElapsedLabel
Set mRemaining = RemainingLabel
mTitle.Caption = mTitleString
Message = mMessageString
With mPgr
.Initialize BackLabel, FrontLabel, CaptionLabel
.Max = mMax
End With
mElapsed.Visible = mWithTimeElapsed
mRemaining.Visible = mWithTimeRemaining
ProcWait
End Sub
Private Sub ProcRun(callProc As String)
If callProc <> "" Then Application.Run callProc
End Sub
Private Sub ProcWait(Optional waitingTime As Single = 0.1)
Dim sgTimer As Single
sgTimer = Timer
Do While Timer < sgTimer + waitingTime
DoEvents
Loop
End Sub
Public Function ProgressCount() As Long
ProgressCount = mCount
End Function
Public Function ProgressStop() As Long
mStop = True
ProgressStop = mCount
End Function
Public Sub ProgressRun()
For mCount = 0 To mPgr.Max
'this allow to either interrupt the loop before the end or
'or just runthe next iteration by calling the procedure given by the caller in ProgressStart
If mStop Then
ProcRun mProcStop
Exit For
Else
If mWithTimeElapsed Then mElapsed.Caption = "Time elapsed: " & TimeElapsed
If mWithTimeRemaining Then mRemaining.Caption = "Estimated time remaining: " & TimeRemaining
If True Then
ProcRun mProcCall
Else
Message = "Loop nr " & CStr(mCount)
End If
End If
mPgr.Increment
'leave the time for the application to manage the display of the popup after each update
ProcWait
Next mCount
If mCount > mPgr.Max Then ProcRun mProcStop 'runs the possible stop procedure if we reach the limit set for the loop execution
DoCmd.Close acForm, "FrmProgress", acSaveNo 'this is the only place where we close the form
End Sub
Public Sub ProgressStart(vMax As Long, sTitle As String, sMessage As String, callProc As String, Optional callStop As String = "", Optional withTimeElapsed As Boolean = False, Optional withTimeRemaining As Boolean = True)
mMax = vMax
mStop = False
mTitleString = sTitle 'this only store the title in a variable so far, it will be set on the label in ProgressRun
mMessageString = sMessage 'this only store the title in a variable so far, it will be set on the label in ProgressRun
mProcCall = callProc
mProcStop = callStop
mWithTimeRemaining = withTimeRemaining
mWithTimeElapsed = withTimeElapsed
mDateStart = Now
'the next line opens the form, and its Load event will call this
'module's ProgressRun procedure to start the whole shenanigan
'it also only in ProgressRun that the form is closed
DoCmd.OpenForm "FrmProgress"
End Sub
Public Sub ProgressUpdate(newMessage As String)
mMessage.Caption = newMessage
End Sub
Public Property Get TimeElapsed() As String
TimeElapsed = TimeToString(Now - mDateStart)
End Property
Public Property Get TimeRemaining() As String
Dim iCount As Integer
Dim dt As Date
'we wait a few cycles to have a significant time reference
If mCount < 5 Then
TimeRemaining = ""
Else
dt = Now - mDateStart
TimeRemaining = TimeToString(dt * ((mPgr.Max / mCount) - 1))
End If
End Property
Private Function TimeToString(dt As Date) As String
Dim intHours As Long
Dim intMinutes As Long
' Calculate the time interval
intHours = Int(CSng(dt * 24))
intMinutes = Int(CSng(dt * 24 * 60)) - intHours * 60
' Format and print the time interval in hours, minutes and seconds.
If intHours > 0 Then TimeToString = intHours & "h"
If intMinutes > 0 Then TimeToString = TimeToString & intMinutes & "min"
TimeToString = TimeToString & Format(dt, "ss") & "s"
End Function
就是这样！将此代码复制到您的模块中，一切都会顺利进行。
祝大家编码愉快。