'A "progress bar" Form in ms-access will not update when its properties are changed from a loop in a module
I am trying to have a dialog form, or rather a dialog-looking form displayed while importing a big quantity of data in my access database, from a "Document Control Process" excel workbook I get an update of every month. It takes up to15 min to import, so I want to show the user a progress dialog showing what is happening, together with a button to interrupt the process before the end if he wants (this is also hugely useful will debugging my procedure).
I have a normal module in which a procedure displays the form and sets it current properties (title, the caption of a label explaining the current operation, the progress bar which in this case are two labels of which I adjust the captions and the sizes). Then it starts the loop to import each document, and in each iteration it updates the form to display the progress.
Except that the forms shows, the title is set and then it freezes until the whole info has been imported 15 minutes later. I have tried adding a few DoEvents in the module (even an lot of them when the few first ones didn't work) but to no avail.
Has someone struggled with that before and could help me? I have looked for it for days now in Stack Overflow and more widely on the net, but this specific issue seems never to be referenced... I mean there is a lot of solutions for progress dialog, which somehow never seem to suffer from that update issue while I get hit by it every single time. I suspect a thread related problem but I just can't pin it.
Solution 1:[1]
Now I have finally been able to find a way to display a generic progress dialog that can be called from anywhere and won't freeze. Thank you SunKnight0 for your comment that sent me on the right path, and to Adams Tips for his answer to the question "Progress bar in in ms-access".
The following description is a bit lengthy, but I think it provides everything needed to implement the progress dialog.
So here's the trick. I include the full solution, so you just have to copy the code in your modules to get it to work. the dialog displays details of what is currently being done, indicates the time elapsed and an estimation of the remaining processing time, and provides a way to cleanly interrupt the process before the end if needed (also handy when debugging your process).
The solution is composed of a form, called FrmProgress here, and a module ModProgress. You call the methods from the module from wherever you want, like you would do for a class, and it handles the form and makes sure that it is updated and won't freeze. For the progress bar itself I am using Adam's class clsLblProg, here renamed CProgressLabel. It is not mandatory but I like the result. This was made for Access but it can easily be exported to Excel.
The secret is that the loop is handled in ModProgress, in the thread of the modal form. At each iteration the module calls a procedure which name is given at the start. At the end, before closing the form, the module can call another procedure once. I use it to display a messagebox recapitulating what was done and, at debug time, the total time elapsed. These two procedures are called using Application.Run, so they need to be in a normal module, not in a form or a class module.
How to use it:
'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
This starts the progress dialog for nbIteration loops, with the title "Importing Dcp...", the initial message "Starting import...". At each iteration the dialog will call the public procedure "DcpImportUnit", at the end it will call the public procedure "DcpImportStop". The elapsed time will be displayed and updated at each iteration. The remaining time will be displayed and updated updated at each iteration.
You will need a form (here called FrmProgress) designed like this:
In design mode, set the form's Pop Up property to Yes, and the Modal property to No. It is normal that no progress bar is visible, as CProgressLabel uses LblBack, LblFront and LblCaption to make one at runtime.
The code of the form is as follow:
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
Then the nice class from Adam, with virtually no modification (I only replaced the direct color values in the Update method by RGBs, with I find clearer):
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
Now the module ModProgress linking everything together:
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
That´s it! Copy this code in your modules and everything should go just smooth.
Good coding to you all.
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
Solution | Source |
---|---|
Solution 1 |