accesstoolbox/source/modules/ProgressDialog.bas

Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Compare Database
Option Explicit

' ** Access Toolbox Module **
' on 2017-02-28,
' @author: Olivier Massot
' V 1.0

' Progress Dialog

' ! Requires the 'zf_progress' form

' usage:
'
'    Dim pdial As New ProgressDialog
'
'    pdial.show "My progress bar", "Operation running...", 100, False
'
'    For i = 0 To 100
'
'        ' ongoing work...
'
'        pdial.update i, "Operation running..."
'    Next i

Private Const fname = "zf_progress"
Private total_prog, current_prog As Double
Private auto_close As Boolean


Public Sub show(title As String, Optional msg As String = "", Optional v_total_prog As Double = 100, Optional v_auto_close As Boolean = False)

    auto_close = v_auto_close
    
    total_prog = IIf(v_total_prog > 0, v_total_prog, 100)
    
    DoCmd.OpenForm fname, acNormal
    With forms(fname)
        .txt_title.Caption = title
        .txt_msg.Visible = (Len(msg) > 0)
        If Len(msg) > 0 Then .txt_msg.Caption = msg
        .prog.Width = 1
        .prog.BackColor = RGB(23, 55, 94)
    End With
    DoCmd.Hourglass True
  
End Sub

Public Sub update(ByVal prog As Double, ByVal msg As String)
    Dim ratio As Double
  
    If prog >= 0 Then
        If prog <= total_prog Then
            current_prog = prog
        Else
            current_prog = total_prog
        End If
    Else
        current_prog = 0
    End If
  
    With forms(fname)
        .SetFocus
        
        .txt_msg.Visible = (Len(msg) > 0)
        If Len(msg) > 0 Then .txt_msg.Caption = CStr(msg)
        
        ratio = current_prog / total_prog
        .prog.Width = 5137 * ratio
        If ratio = 1 Then
            If auto_close = True Then
                Call close_
                Exit Sub
            End If
            DoCmd.Hourglass False
            .prog.BackColor = RGB(23, 55, 94)
            .btn_ok.Visible = True
            .SetFocus
        End If
    End With
    
end_:
  Exit Sub
End Sub

Public Sub close_()
  DoCmd.Hourglass False
  DoCmd.Close acForm, fname, acSaveNo
End Sub

Private Sub class_Terminate()
  Call close_
End Sub