Access 中的进度指示器
简介
Access有一个坏习惯，就是与它的处理联系在一起，而不提供关于它是否崩溃的线索(操作系统和工具只是指示应用程序没有响应，这与应用程序真正崩溃时看到的消息相同)。 不幸的是，他们对此的反应通常是无论如何都会强行崩溃，然后重新开始。 这可能是一个很大的问题，除了事实是这是导致数据库损坏的最可靠的方法之一之外，由于代码通常不被设计为可自我恢复（IE。如果该代码由A，B和C块组成，则有必要按顺序依次运行这些块；如果A运行，则B无法运行，从而导致该过程再次开始，则块A将再次运行。该代码从未设计为在块B运行之前支持A运行两次。 顺便说一句，Access（DAO和ADODB）确实支持事务处理-（ BeginTrans，CommitTrans，Rollback Methods ，但是许多数据库在其设计中并未包含此功能）。
建议的解决方案
首先让我介绍一下
状态栏中的进度指示器 。 Application.SysCmd()提供了该功能。 我无意在此处对此进行任何进一步的详细说明，但是“帮助”系统将对感兴趣的任何人进行完整描述。
我打算讨论的替代概念使用非模式形式。 我在此处包括该设计的图像以说明基本概念。 这是比基本要求更复杂的版本，但是随着时间的推移，我添加了有用的复杂性，并且由于它们已经可用，因此我认为它们也可能会包括在内。
想法是在运行代码的开头显示表格，并预先传递主要步骤的描述，并在每个步骤完成后调用以更新显示。 当控制权最终返回给操作员时，允许表单在预定时间段内保持可见状态（默认为两秒钟），但随后将其关闭。 操作员可以根据需要选择在该最终延迟时间内清除它，方法是单击标题。 此处包括一个实时运行时的图像（这是在完成全部任务之后）。
为了避免表单丢失的问题，例如，当操作员在应用程序上的其他位置单击时，将计时器例程设置为每1/4秒重新选择一次表单。 这样可以确保操作员永远不会因任何原因而恐慌并使应用程序崩溃。
实施
请注意，在顶部标签下面的列表中出现了许多控件，它们表示请等待……每一行由两个控件组成:一个用于指示状态(未启动;运行;完成;隐藏(在这种情况下不运行)，另一个只是显示每个任务的标题。总共有25行，每一行由lblTicknn和lblLabelnn组成，其中nn反映从00 (lblTick00, lblLabel00, lblTick01，…、lblTick24 lblLabel24)。
在显示表单之前，所有不必要的行都会被隐藏起来，因此它的大小只能满足当前任务的需要。
表单本身的代码包含在这里：
Option Compare Database
Option Explicit
'The frmProgress form is designed to stay visible for about 2" after it expires.
'However, the operator can cancel the delay if he clicks on the form's title.
'11/5/2006 Allows ten entries.
'15/5/2006 Resize form to handle only the number of entries required.
' This cannot work as the form size itself never changes on screen.
'18/08/2008 Tried again using Access 2003
Private Const conMaxStep As Integer = 24 'Steps = conMaxSteps + 1 (From 0)
Private Const conDelSecs As Integer = 2 'Default delay in secs
Private Const conProgSep As String = "~" 'Separator character within strMsgs
Private Const conCross As Long = &HFB 'Wingdings cross
Private Const conTick As Long = &HFC 'Wingdings tick
Private Const conCM As Long = &H238 'Centimeter
'intPeriod 1/4"s counted after completion; intDelay 1/4"s to count;
'intLastStep is the last step used on the form
Private intPeriod As Integer, intDelay As Integer, intLastStep As Integer
Private lblTicks(0 To conMaxStep) As Label, lblSteps(0 To conMaxStep) As Label
Private Sub Form_Open(Cancel As Integer)
Dim strStep As String
Dim ctlThis As Control
'Assign all labels to the arrays. Ignore any failures.
On Error Resume Next
For Each ctlThis In Controls
strStep = Right(ctlThis.Name, 2)
Select Case Left(ctlThis.Name, 7)
Case "lblTick"
Set lblTicks(CInt(strStep)) = ctlThis
Case "lblStep"
Set lblSteps(CInt(strStep)) = ctlThis
End Select
Next ctlThis
On Error GoTo 0
End Sub
'intStep = 0 Reset all and set up captions
'intStep = Positive Operate on relevant (intStep-1) line of the display
'intStep = Negative Close Progress form after processing -intStep
' intState = 0 Not started yet - visible / dim
' intState = 1 In progress - visible / bold
' intState = 2 Completed - visible / ticked
' intState = 3 Hidden - visible / dim / crossed
' intState = 4 In progress for intStep - Completed for previous step
' intState = 5 In progress for intStep - Hidden for previous step
Public Sub SetStep(ByVal intStep As Integer, _
Optional ByVal intState As Integer = -1, _
Optional ByRef strMsgs As String = "", _
Optional ByVal intDelSecs As Integer = -1, _
Optional ByVal dblCM As Double = 0)
Dim intIdx As Integer, intTop As Integer
Dim lngSize As Long
Dim blnClose As Boolean
'Cancel any pending close (see Timer code)
intPeriod = 0
'Default intDelSecs if not set
If intDelSecs = -1 Then intDelSecs = conDelSecs
'Default intState depending on intStep
If intState = -1 Then
Select Case intStep
Case 0 'Open - Default = 1 In progress
intState = 1
Case Is > 0 'Change step - Default = 4 Complete & In progress
intState = 4
Case Is < 0 'Close - Default = 2 Complete
intState = 2
End Select
End If
Select Case Abs(intStep)
Case 0 'Reset all and set up captions
intDelay = intDelSecs * 4 + Sgn(intDelSecs)
'find number of elements in strMsgs
intTop = UBound(Split(strMsgs, conProgSep))
If intTop > conMaxStep Then intTop = conMaxStep
For intIdx = 0 To conMaxStep
If intIdx > intTop Then
lblTicks(intIdx).Visible = False
lblSteps(intIdx).Visible = False
Else
lblSteps(intIdx).Visible = True
lblSteps(intIdx).Caption = Split(strMsgs, conProgSep)(intIdx)
Call SetState(intStep:=intIdx, _
intState:=IIf(intIdx = 0, intState, 0))
End If
Next intIdx
'Resize form depending on # of lines used and lngWidth passed
With Me
If intTop < conMaxStep Then
lngSize = (conMaxStep - intTop) * conCM / 2
.boxInner.Height = .boxInner.Height - lngSize
.boxOuter.Height = .boxOuter.Height - lngSize
.InsideHeight = .InsideHeight - lngSize
'Following line depends on Access 2003
Call .Move(Left:=.WindowLeft, Top:=.WindowTop + lngSize / 2)
End If
If dblCM > 0 Then
lngSize = dblCM * conCM
.lblTitle.Width = .lblTitle.Width - lngSize
.boxInner.Width = .boxInner.Width - lngSize
.boxOuter.Width = .boxOuter.Width - lngSize
.InsideWidth = .InsideWidth - lngSize
For intTop = intTop To 0 Step -1
lblSteps(intTop).Width = lblSteps(intTop).Width - lngSize
Next intTop
'Following line depends on Access 2003
Call .Move(Left:=.WindowLeft + lngSize / 2)
End If
End With
Case 1 To conMaxStep + 1
Call SetState(Abs(intStep) - 1, intState)
End Select
If intStep < 0 Then 'Close Progress form
If intDelay = 0 Then Call CloseMe
'Otherwise start timer
intPeriod = 1
End If
'Update the screen
DoEvents
End Sub
Private Sub SetState(intStep As Integer, intState As Integer)
lblTicks(intStep).Caption = Chr(conTick)
lblSteps(intStep).FontBold = False
Select Case intState
Case 0 'Not started yet (dim)
lblTicks(intStep).Visible = False
lblSteps(intStep).ForeColor = vbBlue
Case 1, 4, 5 'In progress (bold)
lblTicks(intStep).Visible = False
lblSteps(intStep).ForeColor = vbRed
lblSteps(intStep).FontBold = True
If intState > 3 And intStep > 0 Then _
Call SetState(intStep:=intStep - 1, intState:=intState - 2)
Case 2 'Completed (Tick)
lblTicks(intStep).Visible = True
lblSteps(intStep).ForeColor = vbRed
Case 3 'Hidden (dim / cross)
lblTicks(intStep).Caption = Chr(conCross)
lblTicks(intStep).Visible = True
lblSteps(intStep).ForeColor = vbBlue
End Select
'Always bring frmProgress to front when updating
Call DoCmd.SelectObject(ObjectType:=acForm, ObjectName:=Me.Name)
'Update the screen
DoEvents
End Sub
Private Sub lblTitle_Click()
If intPeriod > 0 Then Call CloseMe
End Sub
Private Sub Form_Timer()
Select Case intPeriod
Case 0
Exit Sub
Case Is < intDelay
intPeriod = intPeriod + 1
Call DoCmd.SelectObject(ObjectType:=acForm, ObjectName:=Me.Name)
Case Else
Call CloseMe
End Select
End Sub
Private Sub CloseMe()
Call DoCmd.Close(ObjectType:=acForm, ObjectName:=Me.Name)
End Sub使用说明
使用此代码的最基本的要求非常简单，但是确实为包含许多任务的复杂流程提供了灵活性。
代码示例
这是附加的示例数据库中使用的代码：
Option Compare Database
Option Explicit
Private frmProg As Form_frmProgress
Private Sub Form_Open(Cancel As Integer)
Call DoCmd.Restore
If DBWindowVisible() Then
Call DoCmd.SelectObject(ObjectType:=acForm, InDatabaseWindow:=True)
Call DoCmd.RunCommand(Command:=acCmdWindowHide)
End If
End Sub
Private Sub cmdTest_Click()
Dim strMsgs As String
Dim datStart As Date
strMsgs = "Task taking 5 seconds~" & _
"This task takes just 1 second~" & _
"This task is skipped~" & _
"This task takes 20 seconds"
Set frmProg = New Form_frmProgress
Call frmProg.SetStep(intStep:=0, strMsgs:=strMsgs)
datStart = Now()
Do
DoEvents
Loop While Now() < (datStart + (5 / 86400))
Call frmProg.SetStep(intStep:=2)
datStart = Now()
Do
DoEvents
Loop While Now() < (datStart + (1 / 86400))
Call frmProg.SetStep(intStep:=3, intState:=4)
Call frmProg.SetStep(intStep:=4, intState:=5)
datStart = Now()
Do
DoEvents
Loop While Now() < (datStart + (20 / 86400))
Call frmProg.SetStep(intStep:=-4)
End Sub
Private Sub cmdExit_Click()
Call DoCmd.Close
End Sub
Private Sub Form_Close()
'Method must exist in order for container to handle event.
If Not DBWindowVisible() Then _
Call DoCmd.SelectObject(ObjectType:=acForm, InDatabaseWindow:=True)
End Sub- ＃18至＃21-设置四个任务的标题。
- ＃22创建frmProgress表单的实例。
- ＃23对其进行设置并传递需要处理的字幕（以strMsgs为单位）。
- ＃28，＃33，＃34和＃39处理更新各行的状态。
- 特别是＃39，因为负数表示frmProgress应该启动计时器以自行关闭。
附加图片
附加的文件
 |
frmProgress.jpg （84.4 KB，5373观看次数） |
|
frmProgressLive.Jpg （12.5 KB，4935观看次数） |
 |
frmProgress.Zip （1.15 MB，15826视图） |
From: https://bytes.com/topic/access/insights/907658-progress-indicator-access