Bonsoir a tous

j'ai une enigme a vous poser
voila j'ai revu une contrib qui consiste a lister les fichiers d'un dossier ou meme d'un disque dur ainsi que les sous-dossiers en récursivité
avec l'object scriptingfilesystemobject
elle fonctionne tres bien

mais!!!! il y a des détracteurs a cet object lui donnant des adjectifs de gros balourd

ok je revois mes archive et je ressort la meme avec dir en récursivité
je monte la macro comme celle avec Scripting
je constate que selon les fichiers cela plante question d'attribut je crois

ca c'est un premier soucis
le 2d soucis et c'est la l'enigme la fonction avec "DIR" me sort pres de 6000 fichiers

alors qu'avec Scripting j'en ai 12105
j' ai tout essayé

voila la fonction avec le scriptingfilesystemobject
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
 
'=======================================================================================================
'              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("H:\", "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
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
        If Not sous_dossier.Attributes = 22 Then recherche_récursive sous_dossier.Path, ExT, L  ' on rappelle la fonction avec pour argument le chemin du sous dossier ainsi que l'extention et L qui est deja peut etre 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
et maintenant la fonction avec "DIR"

Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
 
Option Explicit
Dim tabl()
Sub test2()
    Dim mesfichiers, Chemin As String, ExT As String, a As Long
 
   Chemin = "H:\"    ' racine pour la recherche
 
    ' ExT = ".mp3,.txt"    ' exemple avec plusieurs extentions recherchés
 
    ExT = "all"    ' extention de fichiers recherchés
 
    mesfichiers = cherche(Chemin, ExT, 0)   '  ||mesfichier|| deviendra un tableau de nom de fichiers selon les condition précédemment énumérée
 
    'exemple d'utilisation: depose la liste des fichier trouvés dans le sheets
    If UBound(mesfichiers) > 0 Then Cells(1, 1).Resize(UBound(mesfichiers), 1) = Application.Transpose(mesfichiers)
End Sub
Function cherche(Dossier, ExT, a)
    Dim Chemin As String, itemsvu As String, nbitemsVu As Long, i As Long, ArrayExT
 
    Chemin = Dossier & "\"
    itemsvu = Dir(Chemin, vbDirectory)
    If ExT = "all" Then ExT = ".,"
    ArrayExT = Split(ExT, ",")
    Do
        nbitemsVu = nbitemsVu + 1
        If itemsvu <> "." And itemsvu <> ".." Then
            'On Error Resume Next
            If (GetAttr(Chemin & itemsvu) And vbDirectory) = vbDirectory Then
                Call cherche(Chemin & itemsvu, ExT, a)
                'Err.Clear
                'après avoir examiné le sous-dossier, il faut repositionner Dir sur l'entrée suivante
                'car la fonction dir n'est pas récursive et a donc perdue la dernière position
                'on réinitialise donc Dir et repositionne le flag à la bonne place avec nbitemsVu
                itemsvu = Dir(Chemin, vbDirectory)
                For i = 1 To nbitemsVu - 1: itemsvu = Dir: Next i
            Else
                For i = 0 To UBound(ArrayExT)
                   If itemsvu Like "*" & ArrayExT(i) Then
                        ReDim Preserve tabl(a)
                        tabl(a) = Chemin & "\" & itemsvu & vbCrLf
                    a = a + 1
                    End If
               Next
            End If
        End If
        itemsvu = Dir
    Loop While itemsvu <> ""
    cherche = tabl
End Function
voila si quelqu'un a une idée ??