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 |
Partager