[VBA-*]Lister les sous-répertoires et les fichiers de ceux-ci

**ouskel'n'or** · 27/04/2007, 22h41

Demande de valider la référence "Microsoft Scripting Runtime"

Inspiré de l'aide en ligne

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
Sub ListerLesSsRepEtLeursFichiers() '(Chemin) 'chemin peut être passé en paramètres
    Dim fso, ListR, sRep, ListF, Rep, LesReps, fich, LesFichs
    Set fso = CreateObject("Scripting.FileSystemObject")
    Chemin = "c:\Program files"
    Set ListR = fso.GetFolder(Chemin)
    Set sRep = ListR.SubFolders
    For Each Rep In sRep
        LesReps = LesReps & Rep.Name
        LesReps = LesReps & vbCrLf
        Set ListF = Rep.Files
        For Each fich In ListF
            LesFichs = LesFichs & fich.Name
            LesFichs = LesFichs & vbCrLf
        Next
        If LesFichs <> "" Then
              MsgBox LesFichs, 0, "Fichiers du répertoire " & Rep.Name
          Else
              MsgBox "Il n'y a pas de fichier dans ce répertoire !", 0, "Répertoire " & Rep.Name
        End If
        LesFichs = ""
    Next
    MsgBox LesReps, 0, "Répertoires du dossier " & Chemin
End Sub

**AlainTech** · 27/04/2007, 22h51

Celle-là, je l'avais déjà faite...
http://www.developpez.net/forums/sho...d.php?t=200523

**ouskel'n'or** · 04/05/2007, 17h00

Pour placer les sous répertoires dans des cellules d'une feuille de calculs, voir là par megapacman

**letienne** · 04/03/2014, 14h51

Une petite variante adaptée de cette procédure qui permet de lister les fichiers d'un type donné (ici des images jpeg) dans un répertoire et toute l'arborescence de celui-ci.
Cette procédure est récursive, je n'ai pas trouver de moyen de faire autrement, ça peut être un peu long si vous souhaitez scanner un disque dur entier.

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
 
'La routine doit être appelée avec comme argument le chemin du dossier racine que l'on veut scanner
 
Sub RecupTypeImage(rPath As String)
Dim oFSO As Scripting.FileSystemObject
Dim rFld As Scripting.Folder
Dim cFld As Scripting.Folder
Dim oFl As File
 
'Appelle la routine permettant d'explorer les fichier windows
Set oFSO = New Scripting.FileSystemObject
'Va chercher le dossier de travail à l'adresse rPath
Set rFld = oFSO.GetFolder(rPath)
 
'La fonction étant appelée plusieurs fois consécutivement, il faut récupérer la première ligne vierge.
'Géré ici avec une boucle, il doit être possible de stocker la variable en global pour gagner en efficacité.
 
Dim line As Integer
line = 1
Do Until ThisWorkbook.Sheets(2).Cells(ligne, 1) = ""
line = line + 1
Loop
'POUR CHAQUE sous dossier
'appel de la fonction avec comme argument le dit sous dossier
For Each cFld In rFld.subfolders
    RecupTypeImage (cFld.Path)
Next cFld
'POUR CHAQUE fichier du dossier
'SI le fichier est du type désiré (ici jpg)
'ALORS On entre dans le classeur le nom du fichier en colonne 1 et son chemin en colonne 2
'enfin on incrémente le numéro de ligne
For Each oFl In rFld.Files
    If oFl.Type = "Image JPEG" Then 'Il est possible d'ajouter plusieurs types (gif, png...) en ajoutant or oFl.Type = "...
        ThisWorkbook.Sheets(1).Cells(ligne, 1) = oFl.Name
        ThisWorkbook.Sheets(1).Cells(ligne, 2) = oFl.Path
        line = line + 1
    End If
Next oFl
End Sub

Je l'ai couplé chez moi à un UserForm qui appelle l'explorateur de fichier Windows pour récupérer le chemin du dossier racine.

**Marc-L** · 04/03/2014, 19h29

Quand c'est trop long, ne pas utiliser FSO mais directement la fonction interne au VBA Dir bien plus véloce …

**kiki29** · 22/03/2014, 14h25

Salut, via les API, trouvé sur le web il y a longtemps sans avoir conservé la référence

Dans un module standard
Affecter un bouton à SelDossierRacine

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
Option Explicit
 
Private Const RDepart = 5
Private Const vbDot = 46
Private Const MAX_PATH As Long = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const vbBackslash = "\"
Private Const ALL_FILES = "*.*"
 
Private Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
 
Private Type WIN32_FIND_DATA
    dwFileAttributes As Long
    ftCreationTime As FILETIME
    ftLastAccessTime As FILETIME
    ftLastWriteTime As FILETIME
    nFileSizeHigh As Long
    nFileSizeLow As Long
    dwReserved0 As Long
    dwReserved1 As Long
    cFileName As String * MAX_PATH
    cAlternate As String * 14
End Type
 
Private Type FILE_PARAMS
    bRecurse As Boolean
    bFindOrExclude As Long
    nCount As Long
    nSearched As Long
    sFileNameExt As String
    sFileRoot As String
End Type
 
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Declare Function FindFirstFile Lib "kernel32" _
        Alias "FindFirstFileA" _
        (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" _
        Alias "FindNextFileA" _
        (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Private Declare Function PathMatchSpec Lib "shlwapi" _
        Alias "PathMatchSpecW" _
        (ByVal pszFileParam As Long, ByVal pszSpec As Long) As Long
 
Private fp As FILE_PARAMS
 
Private Declare Function QueryPerformanceCounter Lib "kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "kernel32" (x As Currency) As Boolean
 
Dim NbDossiers As Long
 
Sub SelDossierRacine()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier Racine"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            Rch .SelectedItems(1)
            NbDossiers = 0
        End If
    End With
End Sub
 
Private Sub Rch(sRacine As String)
Dim Debut As Currency, Fin As Currency, Freq As Currency
 
    With ShDatas
        .Cells.Clear
        .Cells(1, 1) = sRacine
        .Cells(2, 1) = "ALL_FILES"
        .Cells(3, 1) = ""
        .Cells(4, 1) = ""
        .Cells(5, 1) = ""
        .Range("B:B").Clear
    End With
 
    ActiveWindow.ScrollRow = 1
    ActiveWindow.ScrollColumn = 1
 
    Application.ScreenUpdating = False
    With fp
        '   start path
        .sFileRoot = QualifyPath(ShDatas.Cells(1, 1))
        '   file type(s) of interest
        .sFileNameExt = ShDatas.Cells(2, 1)
        .bRecurse = True
        .nCount = 0
        .nSearched = 0
 
        '   0=include, 1=exclude
        .bFindOrExclude = 0
    End With
 
    QueryPerformanceCounter Debut
    SearchForFiles fp.sFileRoot
    QueryPerformanceCounter Fin
    QueryPerformanceFrequency Freq
 
    With ShDatas
        .Cells(3, 1) = Format$(fp.nSearched, "###,###,###,##0")
        .Cells(4, 1) = NbDossiers & " // " & Format$(fp.nCount, "###,###,###,##0")
        .Cells(5, 1) = FormatNumber((Fin - Debut) / Freq, 2) & " s"
 
        .Range("A1:A5").HorizontalAlignment = xlLeft
        .Range("B2").Select
    End With
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub SearchForFiles(sRoot As String)
Dim WFD As WIN32_FIND_DATA
Dim hFile As Long
    hFile = FindFirstFile(sRoot & ALL_FILES, WFD)
    If hFile <> INVALID_HANDLE_VALUE Then
        Do
            '   if a folder, and recurse specified, call method again
            If (WFD.dwFileAttributes And vbDirectory) Then
                If Asc(WFD.cFileName) <> vbDot Then
                    NbDossiers = NbDossiers + 1
                    If fp.bRecurse Then SearchForFiles sRoot & TrimNull(WFD.cFileName) & vbBackslash
                End If
            Else
                '   must be a file ..
                If MatchSpec(WFD.cFileName, fp.sFileNameExt) Then
                    fp.nCount = fp.nCount + 1
                    ShDatas.Cells(fp.nCount + RDepart, 2) = sRoot & TrimNull(WFD.cFileName)
                End If
            End If
            fp.nSearched = fp.nSearched + 1
        Loop While FindNextFile(hFile, WFD)
        Application.StatusBar = NbDossiers & " / " & fp.nCount
    End If
    FindClose hFile
End Sub
 
Private Function QualifyPath(sPath As String) As String
    If Right$(sPath, 1) <> vbBackslash Then
        QualifyPath = sPath & vbBackslash
    Else
        QualifyPath = sPath
    End If
End Function
 
Private Function TrimNull(startstr As String) As String
    TrimNull = Left$(startstr, lstrlen(StrPtr(startstr)))
End Function
 
Private Function MatchSpec(sFile As String, sSpec As String) As Boolean
    MatchSpec = PathMatchSpec(StrPtr(sFile), StrPtr(sSpec)) = fp.bFindOrExclude
End Function

**informer** · 19/01/2017, 09h36

Bonjour à tous et merci pour toutes ces infos.

J'ai recopié le code de kiki29 pour l'adapter en 64bits ici

Par contre je ne sais pas récupérer les valeurs de l'objet WIN32_FIND_DATA de type long.
Donc merci de votre aide pour le bout de code afin de récupérer la valeur des variables de type long de l'instance de WIN32_FIND_DATA

Bonjour chez vous

**kiki29** · 19/01/2017, 15h30

Salut, voir Liste des fichiers d'un dossier : Win 32/64 Bits du 01 Avr 2015

**kiki29** · 19/01/2017, 19h05

Re, qqs recherches mènent ici, à adapter à ton contexte.

[VBA-*]Lister les sous-répertoires et les fichiers de ceux-ci

Contribuez

Discussions similaires

Partager

Partager