MS Access中的进度条

Question

我有一个在Microsoft Access 2010中运行的查询,它需要超过30分钟才能正常运行.我想向最终用户呈现查询的一些状态.进度条会很好,但不是必需的.访问似乎线程很差,并且在查询执行期间锁定紧张,否定我尝试的任何更新.虽然我宁愿鞭打VS并编写我自己的应用程序来执行此操作,但我不得不使用Access.

有任何想法吗？

编辑

我曾经从填充数据库的批处理脚本中运行它,但我希望将它全部包含在Access中.具体来说,"查询"实际上是一个ping一系列主机的VBA脚本.所以我不关心优化时间本身,而只是让最终用户知道它没有被锁定.

Answer 1

我经常这样做

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中的代码等中查看不稳定的查询.可能你可以将慢速查询的工作分成更小的部分,以便有机会更新进度条.但你可以随时展示沙漏; 这告诉用户发生了什么事.

Answer 2

如果其他人可能觉得这个有用,这是我为此目的写的一个类.我一直在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