accesstoolbox/source/modules/Progression.bas

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

Private progTotale, progActuelle As Double
Private fermetureAuto As Boolean
'nécessite le formulaire zfrmProgression

Public Sub Afficher(titre As String, Optional msg As String = "", Optional vProgTotale As Double = 1, Optional vfermetureAuto As Boolean = True)
On Error GoTo err
  fermetureAuto = vfermetureAuto
  If Not formExiste("zfrmProgression") Then GoTo errFrm
  progTotale = IIf(vProgTotale > 0, vProgTotale, 1)
  
  DoCmd.OpenForm "zfrmProgression", acNormal
  With forms![zfrmProgression]
    .txt_titre.Caption = titre
    .txt_msg.Visible = (Len(msg) > 0)
    If Len(msg) > 0 Then .txt_msg.Caption = msg
    .prog.Width = 1
    .prog.BackColor = RGB(228, 108, 10)
  End With
  DoCmd.Hourglass True
  
fin:
  Exit Sub
err:
  DoCmd.Hourglass False
  MsgBox "Erreur: impossible d'afficher le formulaire de progression"
  Debug.Print err.Description
  Call fermer
  GoTo fin
errFrm:
  MsgBox "Erreur: le formulaire zfrmProgression est nécessaire à l'affichage de la progression"
  Debug.Print err.Description
  GoTo fin
End Sub

Public Sub maj(ByVal msg As String, ByVal prog As Double)
  Dim taux As Double
  If Not formExiste("zfrmProgression") Then GoTo errFrm
  If prog >= 0 Then
    If prog <= progTotale Then
       progActuelle = prog
    Else
       progActuelle = progTotale
    End If
  Else
    progActuelle = 0
  End If
  
  With forms![zfrmProgression]
    .SetFocus
    .txt_msg.Visible = (Len(msg) > 0)
    If Len(msg) > 0 Then .txt_msg.Caption = msg
    
    taux = progActuelle / progTotale
    .prog.Width = 5137 * taux
    If taux = 1 Then
       If fermertureAuto = True Then GoTo fermeture
       DoCmd.Hourglass False
       .prog.BackColor = RGB(152, 72, 7)
       .boutonOK.Visible = True
       .SetFocus
    End If
  End With
fin:
  Exit Sub
err:
  DoCmd.Hourglass False
  MsgBox "Erreur: impossible de mettre à jour le formulaire de progression"
  Debug.Print err.Description
  GoTo fin
errFrm:
  DoCmd.Hourglass False
  GoTo fin
fermeture:
  Call fermer
  GoTo fin
End Sub

Public Sub fermer()
On Error GoTo err
  DoCmd.Hourglass False
  DoCmd.Close acForm, "zfrmProgression"
fin:
  Exit Sub
err:
  DoCmd.Hourglass False
  MsgBox "Erreur: impossible de fermer le formulaire de progression"
  Debug.Print err.Description
  GoTo fin
End Sub