Progress bar en boucle pendant exécution de plusieurs macros
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:
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:
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:
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 |
