recherche récursive avec scripting.filesystemobject
Bonsoir a tous
après une demande ressente d'un membre du forum , j'ai ressorti une vieillotte fonction de recherche récursive avec la librairie Scripting.filesystemobject
alors voila
j'ai virer les fonctions"dir" et employé le FSO pour les dossier et!! fichiers
j'ai ajouté aussi la possibilité de rechercher plusieurs extensions différentes ou carrément (tout fichier avec l'argument "all") des exemple sont démontrés dans la sub de test
sub de test
Code:
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
| '=======================================================================================================
' OBJECT : FONCTION DE RECHERCHE RECURSIVE AVEC L'OBJECT SCRIPTING.FILESYSTEMOBJECT =
' createur patricktoulon pour developpez.com =
' date de création 27/06/2010 =
'Modification le 10/12/2016 =
'Modif 1:FSO sert aussi pour boucler sur les fichier =
'Modif 2:on peut maintenant rechercher plusieur extentions differentes =
' ou carrément tout les fichiers avec l'argument "all" =
' =
'=======================================================================================================
Option Explicit
Sub test()
Dim tabl
'exemple d'utilisation on va transposer la liste sur le sheets
'on recherche les fichier pdf et jpg
tabl = recherche_récursive("C:\Users\polux\Desktop\testrecursiverecheche", ".pdf,.jpg") 'chemin entre guillemets a adapter
'on recherche les fichiers text
'tabl = recherche_récursive("C:\Users\polux\Desktop\testrecursiverecheche", ".txt") 'chemin entre guillemets a adapter
'on recherche tout les fichiers toutes extention confondues
'tabl = recherche_récursive("C:\Users\polux\Desktop\testrecursiverecheche", "all") 'chemin entre guillemets a adapter
' exemple 1:depot dans le sheets en colonne A
Sheets(1).Cells(1, 1).Resize(UBound(tabl), 1) = Application.Transpose(tabl)
'exemple 2 remplisage dans une listbox
'Userform1.listbox1.List = recherche_récursive("C:\Users\polux\Desktop\testrecursiverecheche", "all")' tout fichier
End Sub |
fonction
Code:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
| Function recherche_récursive(dparent, ext, Optional L As String) As Variant
Dim FSO As Object, oFolder As Object, folderItem As Object, sous_dossier As Object, Ficher, arrayext As Variant, i As Long
Set FSO = CreateObject("scripting.filesystemobject") ' on declare l'object
If ext = "all" Then ext = ".,." 'on prend toute extention pour "all"
arrayext = Split(ext, ",.") ' on split par le ",."
' regard sur les fichiers
Set folderItem = FSO.GetFolder(dparent) 'on attribue a l'object.getfolder le dossier demandé'Scripting.Folder
For Each Ficher In folderItem.Files 'on boucle sur les fichiers qui sont dans ce dossiers
For i = 0 To UBound(arrayext)
If Ficher Like "*" & arrayext(i) Then L = L & Ficher & vbCrLf
Next
Next
'regard sur les dossiers
Set oFolder = FSO.GetFolder(dparent) 'on attribue a l'object.getfolder le dossier demandé
For Each sous_dossier In oFolder.SubFolders 'on boucle sur les dossiers qui sont dans ce dossiers
recherche_récursive sous_dossier.Path, ext, L ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extension et L qui est déjà peut être remplie
Next sous_dossier
recherche_récursive = Split(L, vbCrLf) 'on coupe la liste par les saut de lignes on a maintenant un array la fonction devient cet array
End Function |
elle commençait a vieillir un peu un petit coup de lifting ca mange pas de pain
voila qu'en pensez vous ;)
