现在我终于能够找到一种方法来显示可从任何地方调用并不会冻结的通用进度对话框。 非常感谢SunKnight0为您发表了正确的道路上的评论，并感谢Adams提示他回答了“ms-access中的进度条”问题。
下面的描述有点冗长，但我认为它提供了实现进度对话框所需的一切。
所以这里的诀窍。我提供了完整的解决方案，因此您只需复制模块中的代码即可使其工作。该对话框显示当前正在执行的内容的详细信息，指示已过去的时间以及剩余处理时间的估计，并提供了在需要结束前彻底中断过程的方法（调试过程时也很方便）。
该解决方案由一个称为FrmProgress的窗体和一个ModProgress模块组成。您可以根据需要从模块中调用方法，就像为班级所做的那样，它会处理表单并确保它已更新并且不会冻结。对于进度条本身，我使用了Adam的class clsLblProg，这里改名为CProgressLabel。这不是强制性的，但我喜欢结果。这是针对Access制作的，但可以轻松导出到Excel。
秘诀在于循环是在ModProgress中，在模态窗体的线程中处理的。在每次迭代时，模块都会调用一个在开始时给出名称的过程。最后，在关闭表单之前，模块可以调用另一个过程。我用它来显示一个消息框来重述所做的事情，并且在调试时间显示已经过去的总时间。这两个过程是使用Application.Run调用的，所以它们需要在普通模块中，而不是在表单或类模块中。
如何使用它：
'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环，标题为“导入DCP ......”，最初的消息“开始导入”。在每次迭代时，对话框将调用公共过程“DcpImportUnit”，最后它将调用公共过程“DcpImportStop”。所用时间将在每次迭代中显示和更新。剩余时间将在每次迭代中显示并更新更新。
您将需要一个形式（这里称为FrmProgress）这样设计的：
在设计模式，表单的弹出窗口属性设置为是，和Modal属性设置为否，这是正常没有进度条可见，因为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
然后从亚当漂亮类，几乎没有修改（我只是位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
就是这样！将这段代码复制到你的模块中，一切都应该顺利。
好的编码给大家。
为什么不直接使用状态栏而不是试图自己创建？另外就我所知，调整MSAccess中元素的大小需要设计/独占模式。您是否尝试过调整文本字段以查看这是否有效？ – SunKnight0
@ SunKnight0，否，创建/删除控件所需的设计模式，更改其属性不需要设计模式。我在一个单独的模式窗口中使用了进程指示器和长进程的当前状态，它可以很好地与DoEvents一起工作，它可以在同一个窗口中工作，这里有其他的错误。我建议在单独的数据库中创建一个简单的测试应用程序，确保它能正常工作，然后找出应用程序为什么不刷新表单。 –