Discussion :

[Harry Covair]

Bonjour le forum,

Je souhaite, en VBA, calculer le nombre total des fichiers présents sur un disque dur.
La seule solution que je connaisse consiste à les compter un par un mais ce n'est pas très pratique et relativement long.
Quelqu'un connait-il une propriété qui donne l'information?
D'avance merci pour vos réponses

Harry

[kiki29]

Salut, à tester et adapter à ton contexte, c'est ce que j'ai de plus rapide.
Affecter un bouton à Test
ShDatas est le CodeName de la feuille recevant les données
Dans un module standard le code suivant :

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
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
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
Option Explicit
Option Base 1
 
Private Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type
 
Private FSO As Object
Private gRow As Long
Private gTotals() As Long
Private SelectedDir As String
Private Slashes As Byte
Public TableauInfos(1, 1000) As String
Public Tableau2Infos(1, 1000) As Long
Public Tableau3Infos(1, 1000) As Long
Private z As Long
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
                                             Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
                                           Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim sStr As String
 
Sub Test()
    ComptageFichiers
    Application.StatusBar = sStr
End Sub
 
Private Function ComptageChaines(strText As String, strTrouve As String) As Long
    ComptageChaines = Len(strText) - Len(WorksheetFunction.Substitute(strText, strTrouve, ""))
End Function
 
Private Sub ComptageFichiers()
Const Msg As String = "Selectionner le dossier contenant les fichiers à lister."
 
    Application.ScreenUpdating = False
 
    z = 1
 
    SelectedDir = GetDirectory(Msg)
    ChDrive SelectedDir
    Application.DisplayStatusBar = True
    Slashes = ComptageChaines(SelectedDir, "\")
 
    If Len(SelectedDir) < 4 Then Slashes = 0
    If SelectedDir = "" Then End
    QueryPerformanceCounter Dep
 
    ShDatas.Columns("A:C").Clear
    NombreFichiers SelectedDir
 
    Application.ScreenUpdating = True
End Sub
 
Private Function GetDirectory(Optional Msg As String) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long
Dim pos As Integer
 
    bInfo.pidlRoot = &H0
 
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Selectionner un Dossier."
    Else
        bInfo.lpszTitle = Msg
    End If
 
    bInfo.ulFlags = &H1
 
    x = SHBrowseForFolder(bInfo)
 
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
    End If
End Function
 
Private Sub NombreFichiers(sFolder As String)
Dim iRow As Long
Dim TotNumFiles As Long
Dim SortColumn As Byte
 
    On Error GoTo Erreurs
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
 
    NombreFichiersDansDossier FSO.GetFolder(sFolder), True
 
    For iRow = LBound(gTotals) To UBound(gTotals)
        TotNumFiles = TotNumFiles + gTotals(iRow)
    Next iRow
 
    ShDatas.Columns("A:D").Clear
 
    With ShDatas.Range("A1:C1").Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
 
    With ShDatas
        .Range("A1:C1").Interior.ColorIndex = 19
        .Range("A2:C2").Interior.ColorIndex = 34
    End With
 
    With ShDatas.Cells(z, 3).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThin
        .ColorIndex = xlAutomatic
    End With
 
    With ShDatas
        .Range("A1:C1").Font.Bold = True
        .Cells(1).Value = "Dossier"
        .Cells(2).Value = "Sous Dossiers"
        .Cells(3).Value = "Fichiers"
 
        .Range(.Cells(2, 1), .Cells(z, 1)) = WorksheetFunction.Transpose(TableauInfos)
        .Range(.Cells(2, 2), .Cells(z, 2)) = WorksheetFunction.Transpose(Tableau3Infos)
        .Range(.Cells(2, 3), .Cells(z, 3)) = WorksheetFunction.Transpose(Tableau2Infos)
 
        .Cells(2, 2).Value = WorksheetFunction.Sum(WorksheetFunction.Transpose(Tableau3Infos)) + (z - 2)
    End With
 
    With Cells(z + 1, 3)
        .Value = WorksheetFunction.Sum(Range(Cells(2, 3), Cells(z, 3)))
        .Font.Bold = True
    End With
 
    ShDatas.Range(Cells(1), Cells(3).End(xlDown)).Columns.AutoFit
    QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
    sStr = "Terminé : " & Format(((Fin - Dep) / Freq), "0.00 s")
 
    With Application
        .ScreenUpdating = True
        .StatusBar = ""
    End With
 
    SortColumn = 1
    If SortColumn > 3 Or SortColumn < 1 Then SortColumn = 1
 
    ShDatas.Range(Cells(1, 1), Cells(z + 1, 4)).Sort Key1:=Cells(SortColumn), Order1:=xlAscending, Header:=xlYes, _
                                                     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                                     DataOption1:=xlSortNormal
 
    If z > 37 Then ActiveWindow.ScrollRow = z - 20
 
RoutineSortie:
    Erase TableauInfos
    Erase Tableau2Infos
    Erase Tableau3Infos
    Set FSO = Nothing
    Exit Sub
 
Erreurs:
    If Err.Number = 429 Then
        MsgBox "Vous n'avez pas Microsoft Scripting " _
               & "Runtime library.", _
               vbCritical, "ERREUR"
    End If
    Application.DisplayStatusBar = True
    Resume RoutineSortie
End Sub
 
Private Function NombreFichiersDansDossier(ByVal DossierCible As Object, Optional rbInit As Boolean = False) As Long
Dim Dossier As Object
    On Error GoTo Erreurs
 
    If rbInit Then
        gRow = 0
        ReDim gTotals(0 To gRow)
        gTotals(gRow) = DossierCible.Files.Count
    End If
 
    TableauInfos(1, z) = DossierCible
    Tableau2Infos(1, z) = DossierCible.Files.Count
    z = z + 1
 
    If ComptageChaines(TableauInfos(1, z - 1), "\") > Slashes + 1 Then
        Tableau2Infos(1, z - 2) = Tableau2Infos(1, z - 2) + Tableau2Infos(1, z - 1)
        Tableau3Infos(1, z - 2) = Tableau3Infos(1, z - 2) + 1
        z = z - 1
    End If
 
    If z > 2 Then
        Application.StatusBar = Tableau2Infos(1, z - 2) & "  Fichiers  dans  " & TableauInfos(1, z - 2)
    End If
 
    For Each Dossier In DossierCible.SubFolders
        gRow = gRow + 1
        ReDim Preserve gTotals(0 To gRow)
        gTotals(gRow) = NombreFichiersDansDossier(Dossier)
    Next Dossier
 
    NombreFichiersDansDossier = DossierCible.Files.Count
 
RoutineSortie:
    Exit Function
Erreurs:
    Resume RoutineSortie
End Function

[Harry Covair]

bonjour kiki29,

merci pour la réponse.
Je n'avais pas précisé que je travaille en 64 bits (mauvais choix, je sais).
Prtsafe a été ajouté devant les quatre functions. Malgré tout, à l'appel de SHBrowseForFolder qui utilise le shell32, Excel s'arrête.
Existe-t-il une solution pour pallier ce problème?
Harry

[kiki29]

Salut, voir ici

[Harry Covair]

Je prends une aspirine et commence la lecture

[Harry Covair]

Bonjour Kiki29,
La solution devenait un peu lourde et, honnêtement, je ne maîtrisais pas tout.
Par contre, j'ai appris beaucoup.
Je suis revenu à mes anciennes amours, à savoir le DOS. Dans une routine VBA, J'envoie le résultat de l'instruction DIR dans un fichier TXT et je récupère les dernières lignes qui donnent la synthèse.
Encore merci d'avoir répondu à ma question

Harry