Exemple de répertoire à lister
Répertoire principale
--- Sous-répertoire 1
--- Fichier.pdf
--- Fichier.doc
--- Sous-répertoire2
---Fichier.pdf
--- Fichier.doc
----Sous-répertoire3
---Fichier.pdf
---Fichier.doc
Fichier.pdf
*********************************
Sommaire
Répertoire principale
Sous-répertoire 1
Fichier.pdf
Fichier.doc
Sous-répertoire2
Fichier.pdf
Fichier.doc
Sous-répertoire3
Fichier.pdf
Fichier.doc
Fichier.pdf
'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...
Bonjour patricktoulonre
bonjour
il suffisait de déplacer une ligne
VB:'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 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" 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) = " F_ " & 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) = " F_ " & 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) = "D_" & oSubDir.Name 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
'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&
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
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("A" & A), Address:= _
Table(I, 1), TextToDisplay:=Mid(Table(I, 1), InStrRev(Table(I, 1), "\") + 1)
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) = 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) = 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) = oSubDir.Name
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
Re-Bonjour patricktoulonBonjour ca n'a rian a voir ça tu peux le faire avec le tableau final au lieu de poser la liste dans la plage dans la sub
j'ai modifié la function pour les prefixe fichier/dossiers
VB:'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& 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 ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("A" & A), Address:= _ Table(I, 1), TextToDisplay:=Mid(Table(I, 1), InStrRev(Table(I, 1), "\") + 1) 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) = 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) = 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) = oSubDir.Name 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
'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 listeFSOGOSUBLIENS()
Dim Table As Variant, tim, Répertoire, Intresult, I&, A&
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
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Range("A" & A), Address:= _
Table(I, 1), TextToDisplay:=Mid(Table(I, 1), InStrRev(Table(I, 1), "\") + 1)
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) = 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) = 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) = "******** TITRE_" & oSubDir.Name
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
'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
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Shell Environ("WINDIR") & "\explorer.exe " & Replace(Target, "DOSSIER:", ""), vbNormalFocus
End Sub
Bonjour patricktoulonre
si ca n'est que ca
les dossier seront en noir et les fichier seront des linksVB:'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
pour ouvrir les dossier rajoute dans le module de la feuille
et voila au double click tu ouvre l'explorateur windows sur le dossierVB:Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) Shell Environ("WINDIR") & "\explorer.exe " & Replace(Target, "DOSSIER:", ""), vbNormalFocus End Sub