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 dans un module pour le userform :
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
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 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
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
Partager