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
|
Option Explicit
Public Enum InclueSubF
ISF_No = 0
ISF_Yes = 1
ISF_AutoOne = 2
ISF_AutoAll = 3
End Enum
Sub test()
Dim tabRetour As Variant
tabRetour = ListFilesInFolder("c:\essai\", True)
End Sub
Function ListFilesInFolder(strFolderName As String, Optional IncludeSubfolders As InclueSubF = ISF_No, Optional strTypeFichier As String) As Variant
' adapté de Ole P Erlandsen
' necessite d'activer la reference Microsoft Scripting RunTime
' Code modifié par Qwazerty le 14/03/2010
' Code initial http://www.developpez.net/forums/d200523/logiciels/microsoft-office/excel/contribuez/lister-fichiers-repertoire-feuille-excel/
' En reponse a la demande de ce post http://www.developpez.net/forums/d891321/logiciels/microsoft-office/excel/macros-vba-excel/boucle-fichiers-repertoire/
' tabTypeFichier represente une liste des differents extensions a prendre en compte lors du dressage de la liste des fichiers, celle ci seront séparé par ; ex: "xls;doc"
' ListFilesInFolder renvoi un tableau contenant le chemin de chaque fichiers
' Code modifié par Qwazerty le 04/12/2011
' Suite à une réponse sur le forum http://www.developpez.net/forums/d1160038/logiciels/microsoft-office/excel/macros-vba-excel/probleme-renvoi-fonction/#post6379727
' hallscar faisait une recherche dans tous les répertoirs si pas de résultat dans le repertoire d'origine
' J'ai trouvé la démarche interessante, voila ce que ça donne
' ISF_Yes, ISF_No : recherche standard systémique ou uniquement dans le répertoir d'origine
' ISF_AutoOne : Recherche systémique jusqu'au 1er résultat trouvé
' ISF_AutoAll : Recherche uniquement dans le répertoir d'origine, puis passe en recherche systémique si aucun résultat
' Corrections : Lors de la recherche dans les sous répertoire, passage de strTypeFichier
' Au même endroit suppression du & ";" systématique qui faussé les résultats...
' : Gestion d'erreur sur l'impossibilité de lire un répertoire
Static FSO As FileSystemObject
Static bNotFirstTime As Boolean
Static tabType As Variant, vType As Variant
Static dicoType As Object
Static strResult As String
Dim bTheFirst As Boolean
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim NeedSubFolder As InclueSubF
'initialisation
bTheFirst = False
If Not bNotFirstTime Then
'On identifi le tout premiere appel de la fonction recursive
bTheFirst = True
Set FSO = CreateObject("Scripting.FileSystemObject")
Set dicoType = CreateObject("Scripting.Dictionary")
If strTypeFichier <> "" Then
'On cré un tableau contenant toutes les extensions / * si rien de precisé
tabType = Split(strTypeFichier, ";")
' a l'aide de ce tableau on renseigne notre dictionnaire
For Each vType In tabType
dicoType.Add vType, "Ext"
Next
End If
bNotFirstTime = True
On Error Resume Next
Set oSourceFolder = FSO.GetFolder(strFolderName)
On Error GoTo 0
'On regarde si le rep existe bien
If oSourceFolder Is Nothing Then
MsgBox "Le répertoir '" & strFolderName & "' n'existe pas." & vbCrLf & "L'execution va prendre fin.", vbExclamation, "Répertoir inconnu"
GoTo finApp
End If
End If
Set oSourceFolder = FSO.GetFolder(strFolderName)
'On assure un suivi d'erreur car les repertoires systemes sont souvent inaccessible
On Error GoTo GestionErr
'On boucle sur tous les fichier present
For Each oFile In oSourceFolder.Files
'On verifie que l'extension du fichier correspond a ce qui est demandé
If dicoType.Exists(ExtractFileExt(oFile.Name)) Or (strTypeFichier = "") Then
'On le rajoute dans la chaine result
strResult = strResult & oFile.Path & ";"
End If
Next oFile
NextRep:
On Error GoTo 0
If strResult = "" Then
'Si pas de résultat trouvé
Select Case IncludeSubfolders
Case ISF_AutoOne, ISF_No
'On conserve les choix d'origine
NeedSubFolder = IncludeSubfolders
Case Else
'On passe en recherche systémique
NeedSubFolder = ISF_Yes
End Select
Else
'Si au poins un résultat
Select Case IncludeSubfolders
Case ISF_Yes
'On conserve le choix d'origine
NeedSubFolder = IncludeSubfolders
Case Else
'On termine la recherche
NeedSubFolder = ISF_No
End Select
End If
'Si on a l'option Sous dossier on boucle sur les sous dossiers
If NeedSubFolder = ISF_Yes Then
For Each oSubFolder In oSourceFolder.SubFolders
'On ajoute les fichiers contenu dans ce rep dans la liste precedente
strResult = Join(ListFilesInFolder(oSubFolder.Path, NeedSubFolder, strTypeFichier), ";")
If strResult <> "" Then strResult = strResult & ";"
Next oSubFolder
End If
finApp:
'On supprime le dernier ";" s'il il exist
If Right(strResult, 1) = ";" Then strResult = Left(strResult, Len(strResult) - 1)
'On renvoi le resulta sous forme de tabelau
ListFilesInFolder = Split(strResult, ";")
'Si on se trouve dans le 1er appel on reinitialise les vaiables Static
'pour ne pas conserver des valeurs static lors d'une prochaine utilisation de la fonction
If bTheFirst Then
Set FSO = Nothing
Set dicoType = Nothing
bNotFirstTime = False
tabType = ""
vType = ""
strResult = ""
End If
GestionErr:
If Err.Number <> 0 Then
Select Case Err.Number
Case 70 'Impossible de lire le répertoire
'On reset l'erreur
Err.Clear
GoTo finApp
Case Else
'On affiche l'erreur et on quitte la procédure
MsgBox Err.Description
'On reset l'erreur
Err.Clear
Resume Next
End Select
End If
End Function
Function ExtractFileExt(strName As String) As String
If InStr(strName, ".") = 0 Then
ExtractFileExt = ""
Else
ExtractFileExt = Mid(strName, InStrRev(strName, ".") + 1)
End If
End Function |
Listing fichier contenu dans un répertoire
Tutoriel : 
Répondre avec citation
le bouton en bas à gauche de la page.
ou bien je fais une erreur ?
Partager