MS Access中的进度条
MS Access中的进度条
提问于 2012-08-15 00:35:25
我有一个查询在Microsoft Access 2010中运行，它需要30分钟才能正常运行。我想向最终用户显示查询的一些状态。进度条很好，但不是必需的。在查询执行过程中，Access的线程化程度似乎很差，并且锁得很紧，这就否定了我尝试的任何更新。虽然我宁愿使用VS并编写自己的应用程序来做这件事，但我还是不得不使用Access。
我过去常常从填充数据库的批处理脚本运行此脚本，但我希望将其全部包含在Access中。具体地说，“查询”实际上是一个对一系列主机执行ping操作的VBA脚本。因此，我不太关心优化时间本身，而是简单地让最终用户知道它没有被锁定。
回答 6
Stack Overflow用户
回答已采纳
发布于 2012-08-15 00:52:34
我经常做这样的事情
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中查看代码或类似代码中的运行查询。也许你可以将慢查询的工作拆分成更小的部分，以便有机会更新进度条。但是您可以始终显示沙漏；这会告诉用户发生了什么事情。
Stack Overflow用户
发布于 2015-01-31 04:34:16
如果其他人觉得这很有用，下面是我为此目的编写的一个类。我一直在我的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 SubStack Overflow用户
发布于 2018-05-09 00:41:35
只是将我的部分添加到上面的集合中，以供将来的读者使用。
如果你想要更少的代码和更酷的UI。查看我的GitHub for Progressbar for VBA
一个可定制的：
Dll适用于MS-Access，但只需稍作更改即可在所有VBA平台上运行。所有代码都可以在示例数据库中找到。
这个项目目前正在开发中，并没有涵盖所有的错误。所以，期待一些吧！
您应该担心第三方dll，如果您担心，请在实现dll之前随时使用任何可信的在线防病毒软件。
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/11956834
复制相关文章
相似问题