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
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
Public Declare Function GetTickCount& Lib "kernel32" () 'pour mesurer le temps d'exécution
Public test As New Collection
Public msg, nbrepVides, nbrep 'pour affichage du tps d'exécution
Sub ListerLesFichiersDunRepertoire()
*******'pour mesurer le temps d'exécution et le message **********
Dim Départ As Double, arrivée As Double, i As Long
Dim mn As Long, ms As Long, sd As Long, tps As String
'******************************************************
Dim Chemin As String 'répertoire parent
'***********************************
Départ = GetTikCount& 'Initialise "l'horloge"
'***********************************
Application.ScreenUpdating = False
'*************** pour sélectionner le dossier contenant les sous dossier **********
Chemin = ChoixDossierFichier()
If Chemin = "" Then Exit Sub
'*************** A remplacer par le chemin du répertoire parent ******************
ListerLesSsRepEtLeursFichiers Chemin
'*********** Juste pour tester la durée de la procédure, et donc à effacer ************
arrivée = GetTickCount&
Durée = arrivée - Départ
mn = Int(Durée / 1000 / 60)
sd = Int((Durée / 1000) - (mn * 60))
ms = Durée - (sd * 1000) - (mn * 1000 * 60)
tps = mn & "mn:" & sd & "s:" & ms & "ms"
MsgBox tps & vbCr & vbCr & "Pour " & test.Count & " fichiers dans " & nbrep & " répertoires dont " & nbrepVides & " répertoires vides " '& msg
'Code pour tester le contenu de la collection et vidage de la collection
PourTesterCeCode '(macro)
nbrepVides = 0
nbrep = 0
'*****************************************************************************************
DoEvents
Set FL1 = Nothing
Application.ScreenUpdating = True
End Sub
Function ChoixDossierFichier()
Dim objShell, objFolder, Chemin, FlagChoix&, msg$, flip, flop
On Error GoTo Fin
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, msg, flip, flop)
If objFolder Is Nothing Then Exit Function
Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path
ChoixDossierFichier = Chemin
Fin::
If Err = 91 Then 'erreur si le répertoire "Mes documents" a été sélectionné
If MsgBox("Avez-vous sélectionné le répertoire ""Mes documents"" ?", vbYesNo, "SÉLECTION DE ""MES DOCUMENTS""") = vbYes Then _
ChoixDossierFichier = "C:\Documents and Settings\" & Environ("Username") & "\Mes documents"
On Error GoTo 0
End If
Set objShell = Nothing
Set objFolder = Nothing
End Function
Function ListerLesFichiers(Chemin) As Boolean
Dim fs, NoLigne
Set fs = Application.FileSearch
With fs
.LookIn = Chemin
.FileType = 4 '1 => tous les fichier, 3 => .Doc, 4 = .xls
If .Execute(SortBy:=msoSortByFileName) > 0 Then
If .FoundFiles.Count < 3 Then
nbrepVides = nbrepVides + 1 'à effacer ********************
ListerLesFichiers = False
Exit Function
Else
ListerLesFichiers = True
End If
For i = 1 To .FoundFiles.Count
test.Add .FoundFiles(i)
Next i
End If
End With
Set fs = Nothing
End Function
Sub ListerLesSsRepEtLeursFichiers(Chemin)
Dim fso, ListRep, sRep, Rep, NotFind$
Set fso = CreateObject("Scripting.FileSystemObject")
Set ListRep = fso.GetFolder(Chemin)
Set sRep = ListRep.SubFolders
For Each Rep In sRep
'****************** pour compter les sous-répeertoires *************
nbrep = nbrep + 1
'*******************************************************************
'ListerLesFichiers(Rep) ' A VALIDER si aucun message de fin
'pour le message de fin, A REMPLACER par ligne ci-dessus
If Not ListerLesFichiers(Rep) Then _
NotFind = NotFind & "- " & Rep & vbCr
'*******************************************************************
Next
Set fso = Nothing
Set ListRep = Nothing
Set sRep = Nothing
'***************************** Message de fin ***************************************
'If NotFind <> "" Then msg = "Aucun fichier n'a été trouvé dans les répertoires :" & vbCr & NotFind
End Sub
Sub PourTesterCeCode()
Dim NoLig As Integer
For NoLig = 1 To test.Count
Cells(NoLig, 1) = test(NoLig)
Next
For NoLig = 1 To test.Count
test.Remove 1
Next
MsgBox test.Count
End Sub |
