Discussion :

[omahabeach]

Bonjour à tous,

J'aimerais intégrer les dossiers et sous dossiers d'un répertoire précis dans une table mais en limitant la recherche de profondeur des sous dossiers par une variable. Ce qui dirait variable = 2 donne (dossier > Sous dossier > sous dossier) et n'irait pas plus bas.

J'ai trouvé sur le grenier access tout le code pour lire l'arborescence mais je trouve pas où ajouter la variable pour limiter la recherche... Pourriez vous m'aider ?
D'avance merci

Voici le code :

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
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
166
Option Compare Database
' CONSTANTES
' ---
' Nom de la table et du champ
Public Const TABLE_FICHIERS = "FICHIERS"
Public Const CHAMP_FICHIER = "Fichier"
' ---
 
' AJOUT D'UN  EN FIN DE CHEMIN
' ---
' Entrée : strFolder <- Chemin à retraiter.
' Sortie : Chemin avec  ajouté à la fin si nécessaire.
'
Function AddBackslash( _
  ByVal strFolder As String) As String
 
  strFolder = Trim(strFolder)
  If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
  AddBackslash = strFolder
End Function
 
 
' ---
' NOMBRE DE DOSSIERS DANS UN DOSSIER DE DEPART
' ---
'
Function CompterSousDossiers(ByVal strDossier As String) As Integer
  ' Variables
  Dim strSousDossier As String
  Dim intSousDossiers As Integer
 
  strDossier = AddBackslash(strDossier)
  intSousDossiers = 0
 
  ' Parcourir les sous-dossiers
  strSousDossier = Dir(strDossier, vbDirectory)
  While strSousDossier <> ""
    If (strSousDossier <> ".") And (strSousDossier <> "..") Then
        If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
            intSousDossiers = intSousDossiers + 1
        End If
    End If
 
    strSousDossier = Dir
  Wend
 
  CompterSousDossiers = intSousDossiers
End Function
 
' ---
' LISTE DE SOUS-DOSSIERS D'UN DOSSIER DE DEPART
' ---
'
Function ListerSousDossiers(ByVal strDossier As String) As Variant
    ' Variables
    Dim intSousDossiers As Integer
    Dim astrSousDossiers() As String
    Dim strSousDossier As String
    Dim intI As Integer
 
    ' Compter les sous-dossiers
    strDossier = AddBackslash(strDossier)
    intSousDossiers = CompterSousDossiers(strDossier)
 
    ' Si aucun sous-dossier, on renvoie un tableau vide
    If (intSousDossiers = 0) Then
        ListerSousDossiers = Array()
        Exit Function
    End If
 
    ' Lire les chemins des sous-dossiers
    ReDim astrSousDossiers(1 To intSousDossiers) As String
    strSousDossier = Dir(strDossier, vbDirectory)
    intI = 1
    While strSousDossier <> ""
        If (strSousDossier <> ".") And (strSousDossier <> "..") Then
            If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
                astrSousDossiers(intI) = strDossier & strSousDossier
                intI = intI + 1
            End If
        End If
 
      strSousDossier = Dir
    Wend
 
    ' Résultat
    ListerSousDossiers = astrSousDossiers
End Function
 
 
' LISTE DU CONTENU D'UN DOSSIER VERS UNE TABLE
' ---
'
Sub ListerFichiersRec( _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnViderTable As Boolean = False, _
    Optional blnCheminComplet As Boolean = True)
 
    ' Variables
    Dim rst As DAO.Recordset
 
    ' Vérifier que le dossier existe bien
    strDossier = AddBackslash(strDossier)
    If Dir(strDossier, vbDirectory) = "" Then
        MsgBox "Dossier introuvable !", vbExclamation
        Exit Sub
    End If
 
 
    ' Ouvrir la table
    Set rst = CurrentDb.OpenRecordset("FICHIERS", dbOpenDynaset)
 
    ' Déclencher le parcours récursif des fichiers
    ListerFichiersRecDetail rst, strDossier, strExtension, blnCheminComplet
 
    ' On libère les ressources
    rst.Close
    Set rst = Nothing
End Sub
 
' ---
' PARCOURS RECURSIF DE DOSSIERS
' ---
'
Sub ListerFichiersRecDetail( _
    rst As DAO.Recordset, _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnCheminComplet As Boolean = True)
 
    ' Quelques variables...
    Dim strFichier As String
    Dim varSousDossiers As Variant
    Dim intI As Integer
 
    ' Lister tous les fichiers du dossier
    DoEvents
    strDossier = AddBackslash(strDossier)
    strFichier = Dir(strDossier & strExtension, vbNormal)
    While strFichier <> ""
        ' Stocker le nom du fichier dans la table
        rst.AddNew
            rst("Fichier") = (blnCheminComplet & strDossier)
        rst.Update
 
        ' Lire le fichier suivant
        strFichier = Dir
    Wend
 
    ' Trouver les sous-dossiers éventuels
    varSousDossiers = ListerSousDossiers(strDossier)
 
    ' S'il y a des sous-dossiers, les parcourir aussi récursivement
    If (UBound(varSousDossiers) > 0) Then
        ' Traiter les sous-dossiers
        For intI = 1 To UBound(varSousDossiers)
          ListerFichiersRecDetail rst, varSousDossiers(intI), strExtension, blnCheminComplet
        Next
    End If
End Sub
 
Sub TestListerFichiersRec1()
    ListerFichiersRec "C:\MES DOCUMENTS", "*.*"
    MsgBox "Terminé !", vbInformation
End Sub

[EricDgn]

Charge dans une table dénommée TFichiers contenant 2 champs texte dénommés NomDossier et NomFichier la liste des dossiers et fichiers.
Une variable n contrôle le niveau de profondeur.

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
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
Option Compare Database
Option Explicit
 
Private n As Integer                        '--- n = niveau de profondeur
 
' ---
' AJOUT \ EN FIN DE CHEMIN
' ---
' Entrée : strFolder <- Chemin à retraiter.
' Sortie : Chemin avec \ ajouté à la fin si nécessaire.
'
Function AddBackslash(ByVal strFolder As String) As String
  strFolder = Trim(strFolder)
  If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
  AddBackslash = strFolder
End Function
 
' ---
' NOMBRE DE DOSSIERS DANS UN DOSSIER DE DEPART
' ---
Function CompterSousDossiers(ByVal strDossier As String) As Integer
  '--- Variables
  Dim strSousDossier As String
  Dim intSousDossiers As Integer
  strDossier = AddBackslash(strDossier)
  intSousDossiers = 0
  '--- Parcourir les sous-dossiers
  strSousDossier = Dir(strDossier, vbDirectory)
  While strSousDossier <> ""
    If (strSousDossier <> ".") And (strSousDossier <> "..") Then
        If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
            intSousDossiers = intSousDossiers + 1
        End If
    End If
    strSousDossier = Dir
  Wend
  CompterSousDossiers = intSousDossiers
End Function
 
' ---
' LISTE DE SOUS-DOSSIERS D'UN DOSSIER DE DEPART
' ---
Function ListerSousDossiers(ByVal strDossier As String) As Variant
    '--- Variables
    Dim intSousDossiers As Integer
    Dim astrSousDossiers() As String
    Dim strSousDossier As String
    Dim intI As Integer
 
    '--- Compter les sous-dossiers
    strDossier = AddBackslash(strDossier)
    intSousDossiers = CompterSousDossiers(strDossier)
 
    '--- Si aucun sous-dossier, on renvoie un tableau vide
    If (intSousDossiers = 0) Then
        ListerSousDossiers = Array()
        Exit Function
    End If
 
    '--- Lire les chemins des sous-dossiers
    ReDim astrSousDossiers(1 To intSousDossiers) As String
    strSousDossier = Dir(strDossier, vbDirectory)
    intI = 1
    While strSousDossier <> ""
        If (strSousDossier <> ".") And (strSousDossier <> "..") Then
            If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
                astrSousDossiers(intI) = strDossier & strSousDossier
                intI = intI + 1
            End If
        End If
 
      strSousDossier = Dir
    Wend
    '--- Résultat
    ListerSousDossiers = astrSousDossiers
End Function
 
 
' ---
' LISTE DU CONTENU D'UN DOSSIER VERS UNE TABLE
' ---
Sub ListerFichiersRec( _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnViderTable As Boolean = False, _
    Optional blnCheminComplet As Boolean = True)
    '--- Variables
    Dim rst As DAO.Recordset
    '--- Vérifier que le dossier existe bien
    strDossier = AddBackslash(strDossier)
    If Dir(strDossier, vbDirectory) = "" Then
        MsgBox "Dossier introuvable !", vbExclamation
        Exit Sub
    End If
    '--- Ouvrir la table
    Set rst = CurrentDb.OpenRecordset("TFichiers", dbOpenDynaset)
    '--- Déclencher le parcours récursif des fichiers
 
    ListerFichiersRecDetail rst, strDossier, strExtension, blnCheminComplet
    '--- On libère les ressources
    rst.Close
    Set rst = Nothing
End Sub
 
' ---
' PARCOURS RECURSIF DE DOSSIERS
' ---
Sub ListerFichiersRecDetail( _
    rst As DAO.Recordset, _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnCheminComplet As Boolean = True)
    '--- Variables...
    Dim strFichier As String
    Dim varSousDossiers As Variant
    Dim intI As Integer
    '--- Lister tous les fichiers du dossier
    DoEvents
    n = n + 1                                               '--- niveau de profondeur
    strDossier = AddBackslash(strDossier)
    strFichier = Dir(strDossier & strExtension, vbNormal)
    While strFichier <> ""
        '--- Stocker le nom du fichier dans la table
         rst.AddNew
         rst("NomDossier") = strDossier
         rst("NomFichier") = strFichier
         rst.Update
        '--- Lire le fichier suivant
        strFichier = Dir
    Wend
    '--- Trouver les sous-dossiers éventuels
    varSousDossiers = ListerSousDossiers(strDossier)
    '--- S'il y a des sous-dossiers, les parcourir aussi récursivement
    If (UBound(varSousDossiers) > 0) And n < 3 Then                     '--- ne va pas plus loin que le 2e niveau
        '--- Traiter les sous-dossiers
        For intI = 1 To UBound(varSousDossiers)
          ListerFichiersRecDetail rst, varSousDossiers(intI), strExtension, blnCheminComplet
        Next
    End If
End Sub
 
Sub TestListerFichiersRec1()
   n = 0
    ListerFichiersRec "C:\Documents", "*.*"
    MsgBox "Terminé !", vbInformation
End Sub

Bonne continuation.

[omahabeach]

Bonjour Eric,

Merci de vous êtes penché sur mon problème.

J'ai testé votre codage mais j'obtiens toujours toute l'arborescence... La valeur n n'a aucun effet...

[EricDgn]

Testé avant envoi et retesté maintenant: cela fonctionne chez moi.
Remplacer n<3 par n<2 et/ou n<1 pour voir ce que cela donne.
Bien vider la table avant chaque test.
Cordialement

[omahabeach]

Je suis désolé Eric,

J'ai effacé tout le code et remis.

Effectivement lorsque n =1 j'ai le 1er niveau de sous dossier
C'est parfait

Après si je mets n = 0 j'ai le même résultat que n =1
si je mets n = 2 ou n= 3 j'obtiens rien (ce qui me semble logique)

Mets en mettant n =0 ne devrais je pas avoir le 1er et le 2ème niveau ?

D'avance merci

[EricDgn]

Attention, ne pas mettre = mais <

[omahabeach]

Au temps pour moi Eric
mais j'ai le même constat
quand je modifie If (UBound(varSousDossiers) > 0) And n < 3 Then

Si je mets 0 ou 1 j'obtiens rien
si je mets 2 ou plus j'obtiens uniquement l'arborescence du 1er niveau....

[omahabeach]

Eric,

Une précision :

Je voudrais l'arborescence des dossiers même si il ne contient pas de fichier, c'est peut être pour ça que je ne vois pas tout.

D'avance merci de ton aide

[omahabeach]

voire je m'en fiche des fichiers

[EricDgn]

Pour cela, modifier cette partie du code

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
    '--- Lister tous les fichiers du dossier
    n = n + 1
    strDossier = AddBackslash(strDossier)
    'strFichier = Dir(strDossier & strExtension, vbNormal)
    strFichier = Dir(strDossier, vbDirectory)
    While strFichier <> ""
        '--- Stocker le nom du fichier dans la table
        If strFichier = "." Then                   '--- liste uniquement les dossiers
        'If strFichier <> ".." Then                 '--- liste dossiers et fichiers
            rst.AddNew
            rst("NomDossier") = strDossier
            rst("NomFichier") = strFichier
            rst.Update
        End If
        '--- Lire le fichier suivant
        strFichier = Dir
    Wend

Cordialement.

[omahabeach]

Super Eric Merci beaucoup de votre aide précieuse !

Donc le niveau d'arbo fonctionne en revanche il ne lit qu'un sous dossier et pas les autres
ex :

Ma racine "C:\MES DOCS\

il lit C:\MES DOCS\UN\
C:\MES DOCS\UN\A
C:\MES DOCS\UN\B
C:\MES DOCS\UN\C
C:\MES DOCS\DEUX\
C:\MES DOCS\TROIS\
C:\MES DOCS\QUATRE\

mais il ne me trouve pas C:\MES DOCS\DEUX\A
ou C:\MES DOCS\TROIS\A

[EricDgn]

Cette fois, cela devrait être bon !

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
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
Option Explicit
 
' ---
' AJOUT \ EN FIN DE CHEMIN
' ---
' Entrée : strFolder <- Chemin à retraiter.
' Sortie : Chemin avec \ ajouté à la fin si nécessaire.
'
Function AddBackslash(ByVal strFolder As String) As String
  strFolder = Trim(strFolder)
  If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
  AddBackslash = strFolder
End Function
 
' ---
' NOMBRE DE DOSSIERS DANS UN DOSSIER DE DEPART
' ---
Function CompterSousDossiers(ByVal strDossier As String) As Integer
  '--- Variables
  Dim strSousDossier As String
  Dim intSousDossiers As Integer
  strDossier = AddBackslash(strDossier)
  intSousDossiers = 0
  '--- Parcourir les sous-dossiers
  strSousDossier = Dir(strDossier, vbDirectory)
  While strSousDossier <> ""
    If (strSousDossier <> ".") And (strSousDossier <> "..") Then
        If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
            intSousDossiers = intSousDossiers + 1
        End If
    End If
    strSousDossier = Dir
  Wend
  CompterSousDossiers = intSousDossiers
End Function
 
' ---
' LISTE DE SOUS-DOSSIERS D'UN DOSSIER DE DEPART
' ---
Function ListerSousDossiers(ByVal strDossier As String) As Variant
    '--- Variables
    Dim intSousDossiers As Integer
    Dim astrSousDossiers() As String
    Dim strSousDossier As String
    Dim intI As Integer
 
    '--- Compter les sous-dossiers
    strDossier = AddBackslash(strDossier)
    intSousDossiers = CompterSousDossiers(strDossier)
 
    '--- Si aucun sous-dossier, on renvoie un tableau vide
    If (intSousDossiers = 0) Then
        ListerSousDossiers = Array()
        Exit Function
    End If
 
    '--- Lire les chemins des sous-dossiers
    ReDim astrSousDossiers(1 To intSousDossiers) As String
    strSousDossier = Dir(strDossier, vbDirectory)
    intI = 1
    While strSousDossier <> ""
        If (strSousDossier <> ".") And (strSousDossier <> "..") Then
            If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
                astrSousDossiers(intI) = strDossier & strSousDossier
                intI = intI + 1
            End If
        End If
 
      strSousDossier = Dir
    Wend
    '--- Résultat
    ListerSousDossiers = astrSousDossiers
End Function
 
 
' ---
' LISTE DU CONTENU D'UN DOSSIER VERS UNE TABLE
' ---
Sub ListerFichiersRec( _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnViderTable As Boolean = False, _
    Optional blnCheminComplet As Boolean = True)
    '--- Variables
    Dim rst As DAO.Recordset
    '--- Vérifier que le dossier existe bien
    strDossier = AddBackslash(strDossier)
    If Dir(strDossier, vbDirectory) = "" Then
        MsgBox "Dossier introuvable !", vbExclamation
        Exit Sub
    End If
    '--- Ouvrir la table
    Set rst = CurrentDb.OpenRecordset("TFichiers", dbOpenDynaset)
    '--- Déclencher le parcours récursif des fichiers
 
    ListerFichiersRecDetail rst, strDossier, 1, strExtension, blnCheminComplet
    '--- On libère les ressources
    rst.Close
    Set rst = Nothing
End Sub
 
' ---
' PARCOURS RECURSIF DE DOSSIERS
' ---
Sub ListerFichiersRecDetail( _
    rst As DAO.Recordset, _
    ByVal strDossier As String, _
    n As Integer, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnCheminComplet As Boolean = True)
    '--- Variables...
    Dim strFichier As String
    Dim varSousDossiers As Variant
    Dim intI As Integer
    '--- Lister tous les fichiers du dossier
    strDossier = AddBackslash(strDossier)
    'strFichier = Dir(strDossier & strExtension, vbNormal)
    strFichier = Dir(strDossier, vbDirectory)
    While strFichier <> ""
        '--- Stocker le nom du fichier dans la table
        If strFichier = "." Then                   '--- liste uniquement les dossiers
        'If strFichier <> ".." Then                 '--- liste dossiers et fichiers
            rst.AddNew
            rst("NomDossier") = strDossier
            rst("NomFichier") = strFichier
            rst.Update
        End If
        '--- Lire le fichier suivant
        strFichier = Dir
    Wend
    '--- Trouver les sous-dossiers éventuels
    varSousDossiers = ListerSousDossiers(strDossier)
    '--- S'il y a des sous-dossiers, les parcourir aussi récursivement
    If (UBound(varSousDossiers) > 0) And n < 4 Then
        '--- Traiter les sous-dossiers
        For intI = 1 To UBound(varSousDossiers)
          ListerFichiersRecDetail rst, varSousDossiers(intI), n + 1, strExtension, blnCheminComplet
        Next
    End If
End Sub
 
Sub TestListerFichiersRec1()
    ListerFichiersRec "C:\Documents", "*.*"
    MsgBox "Terminé !", vbInformation
End Sub

Cdlt

[omahabeach]

Je testerai ça jeudi et vous tiens au courant.

Encore mille mercis Eric !

[omahabeach]

Bonjour Eric,

Cela fonctionne parfaitement !
Bravo et merci beaucoup !

[omahabeach]

Eric,

Je cherche desespérement comment, maintenant que j'ai l'arborescence dans un champ pouvoir le deconcatener pour mettre à chaque "\" le nom du dossier dans un champ.
Je cherche autour de la fonction gauche d'une requete de Mise à jour mais ne trouve pas...

Sauriez vous ?

D'avance merci

[EricDgn]

Quels sont les noms des champs à compléter ?

[omahabeach]

Peu importe Eric, champs A - B - C

[EricDgn]

Une version. TFichiers avec 5 champs: NomDossier, NomFichier, Dossier1, Dossier2, Dossier3.

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
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
Option Explicit
 
' ---
' AJOUT \ EN FIN DE CHEMIN
' ---
' Entrée : strFolder <- Chemin à retraiter.
' Sortie : Chemin avec \ ajouté à la fin si nécessaire.
'
Function AddBackslash(ByVal strFolder As String) As String
  strFolder = Trim(strFolder)
  If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
  AddBackslash = strFolder
End Function
 
' ---
' NOMBRE DE DOSSIERS DANS UN DOSSIER DE DEPART
' ---
Function CompterSousDossiers(ByVal strDossier As String) As Integer
  '--- Variables
  Dim strSousDossier As String
  Dim intSousDossiers As Integer
  strDossier = AddBackslash(strDossier)
  intSousDossiers = 0
  '--- Parcourir les sous-dossiers
  strSousDossier = Dir(strDossier, vbDirectory)
  While strSousDossier <> ""
    If (strSousDossier <> ".") And (strSousDossier <> "..") Then
        If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
            intSousDossiers = intSousDossiers + 1
        End If
    End If
    strSousDossier = Dir
  Wend
  CompterSousDossiers = intSousDossiers
End Function
 
' ---
' LISTE DE SOUS-DOSSIERS D'UN DOSSIER DE DEPART
' ---
Function ListerSousDossiers(ByVal strDossier As String) As Variant
    '--- Variables
    Dim intSousDossiers As Integer
    Dim astrSousDossiers() As String
    Dim strSousDossier As String
    Dim intI As Integer
 
    '--- Compter les sous-dossiers
    strDossier = AddBackslash(strDossier)
    intSousDossiers = CompterSousDossiers(strDossier)
 
    '--- Si aucun sous-dossier, on renvoie un tableau vide
    If (intSousDossiers = 0) Then
        ListerSousDossiers = Array()
        Exit Function
    End If
 
    '--- Lire les chemins des sous-dossiers
    ReDim astrSousDossiers(1 To intSousDossiers) As String
    strSousDossier = Dir(strDossier, vbDirectory)
    intI = 1
    While strSousDossier <> ""
        If (strSousDossier <> ".") And (strSousDossier <> "..") Then
            If (GetAttr(strDossier & strSousDossier) And vbDirectory) <> 0 Then
                astrSousDossiers(intI) = strDossier & strSousDossier
                intI = intI + 1
            End If
        End If
 
      strSousDossier = Dir
    Wend
    '--- Résultat
    ListerSousDossiers = astrSousDossiers
End Function
 
 
' ---
' LISTE DU CONTENU D'UN DOSSIER VERS UNE TABLE
' ---
Sub ListerFichiersRec( _
    ByVal strDossier As String, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnViderTable As Boolean = False, _
    Optional blnCheminComplet As Boolean = True)
    '--- Variables
    Dim rst As DAO.Recordset
    '--- Vérifier que le dossier existe bien
    strDossier = AddBackslash(strDossier)
    If Dir(strDossier, vbDirectory) = "" Then
        MsgBox "Dossier introuvable !", vbExclamation
        Exit Sub
    End If
    '--- Ouvrir la table
    Set rst = CurrentDb.OpenRecordset("TFichiers", dbOpenDynaset)
    '--- Déclencher le parcours récursif des fichiers
 
    ListerFichiersRecDetail rst, strDossier, 1, strExtension, blnCheminComplet
    '--- On libère les ressources
    rst.Close
    Set rst = Nothing
End Sub
 
' ---
' PARCOURS RECURSIF DE DOSSIERS
' ---
Sub ListerFichiersRecDetail( _
    rst As DAO.Recordset, _
    ByVal strDossier As String, _
    n As Integer, _
    Optional ByVal strExtension As String = "*.*", _
    Optional blnCheminComplet As Boolean = True)
    '--- Variables...
    Dim strFichier As String
    Dim varSousDossiers As Variant
    Dim intI As Integer
    Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long
    '--- Lister tous les fichiers du dossier
    strDossier = AddBackslash(strDossier)
    'strFichier = Dir(strDossier & strExtension, vbNormal)
    strFichier = Dir(strDossier, vbDirectory)
    While strFichier <> ""
        '--- Stocker le nom du fichier dans la table
        If strFichier = "." Then                   '--- liste uniquement les dossiers
        'If strFichier <> ".." Then                 '--- liste dossiers et fichiers
            rst.AddNew
            k1 = InStr(strDossier, "\")
            k2 = InStr(k1 + 1, strDossier, "\")
            k3 = InStr(k2 + 1, strDossier, "\")
            If k3 > 0 Then
               k4 = InStr(k3 + 1, strDossier, "\")
            Else
               k4 = 0
            End If
            rst("NomDossier") = strDossier
            If k4 > 0 Then
               rst("Dossier3") = Mid(strDossier, k3 + 1, k4 - k3 - 1)
            End If
            If k3 > 0 Then
               rst("Dossier2") = Mid(strDossier, k2 + 1, k3 - k2 - 1)
            End If
            rst("Dossier1") = Mid(strDossier, k1 + 1, k2 - k1 - 1)
            rst("NomFichier") = strFichier
            rst.Update
        End If
        '--- Lire le fichier suivant
        strFichier = Dir
    Wend
    '--- Trouver les sous-dossiers éventuels
    varSousDossiers = ListerSousDossiers(strDossier)
    '--- S'il y a des sous-dossiers, les parcourir aussi récursivement
    If (UBound(varSousDossiers) > 0) And n < 3 Then
        '--- Traiter les sous-dossiers
        For intI = 1 To UBound(varSousDossiers)
          ListerFichiersRecDetail rst, varSousDossiers(intI), n + 1, strExtension, blnCheminComplet
        Next
    End If
End Sub
 
Sub TestListerFichiersRec2()
    ListerFichiersRec "C:\Documents", "*.*"
    MsgBox "Terminé !", vbInformation
End Sub

Bonne continuation.

[omahabeach]

Bravo et merci Eric !