Bonjour,

J'aimerais afficher un userform avec une progress bar qui tourne en boucle pendant que du code s’exécute en arrière plan.
J'ai une procédure qui en appelle plusieurs autres. J'aimerais que tous le code roule en background mais je n'y arrive pas.

J'arrive à afficher le userform, mais il est soit tout blanc, soit il se fige... J'ai l'impression qu'il faudrait que je mette "DoEvents" partout mais c'est démesuré de vouloir faire ça.
J’espère donc avoir votre aide ou un exemple de fichier qui fait ça.

Merci d'avance.

Code du userform de progression

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
 
Private Sub UserForm_Activate()
    UpdateProgressBar
End Sub
 
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        StopProgressBar
End Sub
Code dans un module pour le userform :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Option Explicit
 
Private dtmDate As Date
Public Counter As Long
 
Sub UpdateProgressBar()
    Counter = (Counter + 1)
    If Counter > 100 Then Counter = 0
    UsfChargement.ProgressBar1.Value = Counter
    DoEvents
    dtmDate = Now + TimeSerial(0, 0, 1)
    Application.OnTime dtmDate, "UpdateProgressBar"
End Sub
 
Sub StopProgressBar()
    Application.OnTime dtmDate, "UpdateProgressBar", , False
End Sub
Un exemple succin de code qui appel le Userform
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Sub DeplacerFichier()
Dim CheminSortie, dossiersource As String
Dim i, j As Integer
 
 
Application.DisplayAlerts = False
'Application.ScreenUpdating = False
 
UsfChargement.Show False
 
If PresenceDoublons = True Then
    PeuFermer = True
    UsfChargement.Hide
    MsgBox "Erreur, il existe des aubes en doublons dans le dossier : " & Sheets("Formulaire").Range("B1") & Chr(13) & _
    "Arrêt de la procédure. Veuillez supprimer l'un des deux fichiers", vbCritical, "Erreur"
    Exit Sub
End If
 
End Sub
 
Function PresenceDoublons() As Boolean
Dim requete As String
Call ConnexionBase(ThisWorkbook.FullName)
If SheetExists("Doublons") = True Then
    ThisWorkbook.Sheets("Doublons").Delete
End If
 
requete = "Select * From (Select Count(NomFichier) as NmbFichiers, NomFichier, Chemin, DateLastModif From [Indexation$] Where NomFichier " & _
          "In(Select UCase(SN) From [ImportPirat$]) Group By NomFichier, Chemin, DateLastModif) Where NmbFichiers>1"
Rst.Open requete, Cn, adOpenStatic
If Rst.RecordCount > 0 Then
    ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)).Name = "Doublons"
    With ThisWorkbook.Sheets("Doublons")
        .Range("A1") = "Nmb Doublons"
        .Range("B1") = "Fichier"
        .Range("C1") = "Chemin fichier"
        .Range("D1") = "Date Derniere Modif"
        .Range("A2").CopyFromRecordset Rst
    End With
    PresenceDoublons = True
Else
    PresenceDoublons = False
End If
Call DeconnexionBase
End Function