A "progress bar" Form in ms-access will not update when its properties are changed from a loop in a module

Question

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.

Answer 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.