我经常做这样的事情
Dim n As Long, db As DAO.Database, rs As DAO.Recordset
'Show the hour glass
DoCmd.Hourglass True
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT ...")
rs.MoveLast 'Needed to get the accurate number of records
'Show the progress bar
SysCmd acSysCmdInitMeter, "working...", rs.RecordCount
rs.MoveFirst
Do Until rs.EOF
'Do the work here ...
'Update the progress bar
n = n + 1
SysCmd acSysCmdUpdateMeter, n
'Keep the application responding (optional)
DoEvents
rs.MoveNext
Loop
rs.Close: Set rs = Nothing
db.Close: Set db = Nothing
'Remove the progress bar
SysCmd acSysCmdRemoveMeter
'Show the normal cursor again
DoCmd.Hourglass False
注意：当然，您必须以编程方式完成工作才能使其正常工作。您无法在 Access 中查看代码或类似内容中的运行查询。可能您可以将慢速查询的工作拆分成更小的部分，以便有机会更新进度条。但是你总是可以展示沙漏；这告诉用户正在发生一些事情。
如果其他人可能觉得这很有用，这里是我为此目的编写的一个类。我一直在我的 Access 开发项目中使用它。只需将其放入您的项目中名为 的类模块clsLblProg中，然后像这样使用它：
这会产生一个不错的小进度条：
在您的表单上，您只需要三个标签。将背面标签设置为所需大小，并将其他两个隐藏。其余的由班级完成。
这是代码clsLblProg：
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 = 16777215 ' white
Else
mlblCaption.ForeColor = 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
只需将我的部分添加到上述集合中，以供将来的读者使用。
如果您追求更少的代码并且可能是酷的用户界面。查看我的GitHub 以获取 VBA 的进度条
一个可定制的：
该 Dll 被认为适用于 MS-Access，但应在所有 VBA 平台上工作，只需稍作改动。所有代码都可以在示例数据库中找到。
该项目目前正在开发中，并未涵盖所有错误。所以期待一些！
您应该担心第 3 方 dll，如果您担心，请在实施 dll 之前随意使用任何受信任的在线防病毒软件。
由于可用控件的问题，我使用 2 个矩形创建了一个自制的进度条。一个边框和实心条，随着事情的进展而调整大小。边框前面的进度矩形。使用
If pbar Is Nothing Then
Set pbar = New pBar_sub
pbar.init Me.Progressbar_border, Me.ProgressBar_Bar
End If
pbar.value = 0
pbar.show
pbar.max = 145 ' number of interations
...
...
Do While Not recset.EOF
count = count + 1
pbar.value = count
' get next
recset.MoveNext
Loop
可以将状态行与通知正在处理的元素的进度条相关联。赞：123. District SomeWhere，销售代理 WhomEver
======== 进度条替代 pBar_sub ===============
Option Compare Database
Option Explicit
Dim position As Long
Dim maximum As Long
Dim increment As Single
Dim border As Object
Dim bar As Object
Sub init(rect As Object, b As Object)
Set border = rect
Set bar = b
bar.width = 0
hide
End Sub
Sub hide()
bar.visible = False
border.visible = False
End Sub
Sub show()
bar.visible = True
border.visible = True
End Sub
Property Get Max() As Integer
Max = maximum
End Property
Property Let Max(val As Integer)
maximum = val
increment = border.width / val
End Property
Property Get value() As Integer
value = position
End Property
Property Let value(val As Integer)
position = val
bar.width = increment * value
End Property
更新进度条 (acSysCmdUpdateMeter) 后使用命令DoEvents 。
如果有大量记录，则仅每 x 次执行一次 DoEvents，因为这会稍微减慢您的应用程序的速度。
这不是一种专业的方式，但如果你喜欢它可以应用。如果您使用的是表单，您可以在方便的位置放置一个默认为绿色的小文本框。
假设文本框名称为TxtProcessing，
属性可以如下。
Name : TxtProcessing
Visible : Yes
Back color : Green
Locked: Yes
Enter Key Behavior : Default
1) 在您的 VB 脚本中，您可以将Me.TxtProcessing.BackColor = vbRed红色表示为进程中的任务。
2) 你可以编写所有的脚本
3) 最后你可以把Me.TxtProcessing.BackColor = vbGreen
Me.TxtProcessing.BackColor = vbRed
Me.TxtProcessing.SetFocus
Me.Refresh
Your Code here.....
Me.TxtProcessing.BackColor = vbGreen
Me.TxtProcessing.SetFocus
:-) 有趣但目的达到了。
首先在 MS Access 窗体中拖动进度条控件，然后将进度条的名称更改为aa.
然后转到代码form property中的计时器:write
me.aa.value=me.aa.value+20
时间间隔 300 根据您的选择。运行表单你会看到进度条