'VERSION MODIFIEE POUR <<"netparty sur ExcelDownload >>"
'**************************************************************
'fonction récursive pour lister les fichiers d'un disque ou dossier
'Utilisation de filesystemobject(FSO)
'Auteurs Dudu2 et patricktoulon sur exceldownload
'version 1.5
'Date:08/02/2021
'mise en place du principe (Part name) valable aussi pour (si juste extension demandée:ex;[*.XXX])
'suppression du stockage des erreurs et des msgbox d'erreur
'suppression commentaires
'utilisation d'une fonction de transposition de l'array simplifiée (horizontal(1 dim) To vertical(2 dim))pour palier au limite de la fonction transpose d'excel
'Date:08/02/2021
'accélération du processus
'en ajoutant du test dir non bloquant pour zapper les dossiers
'ne contenant pas de fichier avec l'extension ou la partie du nom demandée
'Date:13/02/2021
'remplacement du bloc <<if takeit>> par un jumping (etiquette "ScanFolder")
'pour jumper directement sur la boucle des dossiers on zappe directement la partie du code boucle ofile si pas de fichier
'****************************************************************
Option Explicit
Option Compare Text
Dim Appelcount
Dim countdoss
Function TransposeArray(arr) ' fonction de transposition pour palier au limites de la fonction transpose d'excel
Dim tbl(), I&: ReDim tbl(LBound(arr) To UBound(arr), 1 To 1)
For I = LBound(arr) To UBound(arr): tbl(I, 1) = arr(I): Next
TransposeArray = tbl
End Function
'
Sub listeFSOGOSUB()
Dim Table As Variant, tim, Répertoire, Intresult, I&, A&, prefixe
Dim REPSOMMAIRE As Object, cheminsommaire$
ActiveSheet.Range("A1:A" & Rows.Count).ClearContents
With Application.FileDialog(msoFileDialogFolderPicker)
Intresult = .Show
If Intresult <> 0 Then Répertoire = .SelectedItems(1) & "\" Else Exit Sub
End With
tim = Timer
Const Ext$ = "*" 'mettre ici l'extention de fichier que vous cherchez
Appelcount = 0 '
countdoss = 0
Table = FSO_List_FICHIERS2(Répertoire, Ext)
If IsArray(Table) Then
Table = TransposeArray(Table)
tim = Format(Timer - tim, "#0.000 S")
MsgBox UBound(Table) & " fichier(s) <""" & Ext & """> trouvé(s) dans le répertoire <" & Répertoire & "> en " & tim & " s/" & _
vbCrLf & "pour " & Appelcount & " appels de la fonction dans dossier et sous dossier" & vbCrLf & countdoss & " dossiers utilement explorés"
For I = LBound(Table) To UBound(Table)
A = A + 1
If Left(Table(I, 1), 8) = "DOSSIER:" Then
With ActiveSheet.Range("A" & A): .Value = Table(I, 1): .Hyperlinks.Delete: .Font.Color = vbBlack: End With
Else
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("A" & A), Address:= _
Replace(Table(I, 1), "FICHIER:", ""), TextToDisplay:=Left(Table(I, 1), 8) & Mid(Table(I, 1), InStrRev(Table(I, 1), "\") + 1)
End If
Next
'ActiveSheet.Range("A1").Resize(UBound(Table)).Value = Table
Else
MsgBox "Aucun fichier dans le répertoire <" & Répertoire & ">" & vbCrLf & "ayant une partie du nom contenant " & Ext
End If
End Sub
Function FSO_List_FICHIERS2(ByVal Folder As Variant, Optional PartName As String = "") As Variant
Static tbl() As String: Static NbFichiers As Long: Static oFSO As Object
Appelcount = Appelcount + 1
countdoss = countdoss + 1
Dim oDir As Object, oSubDir As Object, oFile As Object, First_Call As Boolean, TakeIT As Boolean
If TypeOf Folder Is Object Then 'si ce nest pas le premier appel Foler est un objet folder membre de FSO
First_Call = False 'si ce nest pas le premier appel on positionne First_Call a false des les 2d appel
Set oDir = Folder 'si ce nest pas le premier appel Odir est donc un object Folder membre de FSO
Else 'si c'est le premier appel Folder est de type string
First_Call = True 'si c'est le premier appel first_call est a true
Erase tbl 'si c'est le premier appel on eraze la variable tableau <<tbl>>
NbFichiers = 0 'si c'est le premier appel on met la variables NbFichiers à 0
Set oFSO = CreateObject("Scripting.FileSystemObject") 'si c'est le premier appel on créée l'object FSO
If Right(Folder, 1) <> "\" Then Folder = Folder & "\" 'si c'est le premier appel si le slach de fin on l'ajoute
Set oDir = oFSO.getfolder(Folder) 'si c'est le premier appel on instruit l'object Folder<<Odir>>avec le string du dossier
End If
TakeIT = True 'on met la variable Takeit à true d'office
' on ouvre une gestion d'erreur globale (pour les permissions refusées ou les noms portants des caracteres speciaux)
'la gestion est valable aussi pour la boucle subFolder elle es fermé a chaque fin d'appels récursifs
On Error Resume Next
If Len(PartName) > 0 Then TakeIT = Len(Dir(oDir.Path & "\" & PartName)) > 0 'si partname demandé on test de presence de (fichier avec PartName dans le nom) dans le dossier en une seule fois
If Err.Number <> 0 Or TakeIT = False Then Err.Clear: countdoss = countdoss - 1: GoSub Scanfolder ' si erreur ou TakeIt =false on zappe l'exploration des fichiers on va directement à l'exploration des sous dossiers avec gosub
For Each oFile In oDir.Files 'boucle sur les fichiers
If Err.Number = 0 Then 'si pas d'erreur
If Len(PartName) = 0 Then 'si pas de PartName demandé on memorise le fichier directement
NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = "FICHIER:" & oDir.Path & "\" & oFile.Name
Else 'si PartName demandé on teste si le nom de fichier like PartName
If oFile.Name Like PartName Then NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = "FICHIER:" & oDir.Path & "\" & oFile.Name 'Stocke le nom complet du fichier en table
End If
End If
Err.Clear ' on clear l'erreur au cas ou
Next oFile
Scanfolder: ' etiquette du jumping d'exploration
For Each oSubDir In oDir.subfolders ' boucle sur les dossiers
NbFichiers = NbFichiers + 1: ReDim Preserve tbl(1 To NbFichiers): tbl(NbFichiers) = "DOSSIER:" & oSubDir.Path
If Err.Number = 0 Then
FSO_List_FICHIERS2 oSubDir, PartName ' on relance la fonction ( appel récursif)
Else: Err.Clear ' sinon on clear l'erreur si dossier interdit ou special
End If
Next oSubDir
On Error GoTo 0 ' ferme la gestion d'erreur globale
' si c'est le premier appel donc on a lu tout l'arborescence en appels récursifs on peut maintenant instruire le return de la fonction avec le tableau
If First_Call Then
FSO_List_FICHIERS2 = False ' on met le return de la fonction a false
If NbFichiers > 0 Then FSO_List_FICHIERS2 = tbl ' si NbFichiers est plus grand que 0 le return de la fonction est la tableau
End If
End Function
