Liste dossiers par VBA [Résolu]

[orambaud]

Je cherche à récuperer la liste des dossiers d'une arborescence de l'explorateur Windows.
J'ai pas mal cherché sur l'aide VBA d'Access et Excel, mais je n'ai pas réussi.
Merci de votre aide.

[ucfoutu]

Bonjour,

S'agit-il de dossiers présent dans une seule branche de ton arborescence ou s'agit-il de dossiers répartis entre différentes branches ?

S'ils sont tous dans la même branche, c'est ultra facile et peu cher...

Tu dis ...

[orambaud]

Les dossiers recherchés sont tous dans le même dossier source.
Merci

[ucfoutu]

Voilà donc :

Exemple :

Un bouton de commande Command1 et une listbox List1

Code

Code :

1
2
3
4
5
6
7
8
9
10
11
12
Private Sub Command1_Click()
  monrepprinc = "d:\monoutil\"  'mets ici TON répertoire contenant tes dossiers
  mesrepssub = Dir(monrepprinc, vbDirectory)
  Do While mesrepssub <> ""
    If mesrepssub <> "." And mesrepssub <> ".." Then
       If (GetAttr(monrepprinc & mesrepssub) And vbDirectory) = vbDirectory Then
         List1.AddItem mesrepssub
       End If
    End If
    mesrepssub = Dir
  Loop
End Sub

[orambaud]

C'est super.
Dernière question, pour les sous-dossiers, que dois-je rajouter?

[ucfoutu]

Envoyé par ucfoutu

Bonjour,

S'agit-il de dossiers présent dans une seule branche de ton arborescence ou s'agit-il de dossiers répartis entre différentes branches ?

S'ils sont tous dans la même branche, c'est ultra facile et peu cher...

Tu dis ...

ce à quoi tu as répondu :

Les dossiers recherchés sont tous dans le même dossier source.
Merci

Alors ?

L'aspect est maintenant totalement différent et il te faut jouer avec la récursivité.
Mais moi, je m'arrête maintenant ici dans cette discussion-ci, telle qu'elle a été "définie" par toi.

[Lou Pitchoun]

Salut,

Ceci devrait t'aider.
http://vb.developpez.com/faq/?page=Fichiers#rep_sousrep

[philben]

bonjour,

voici une version sans utiliser la référence "scripting runtime" mais seulement VBA.

Fonction principale :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 
Public Function GetSubDirs(ByVal sRacine As String, ByRef asDirs() As String) As Integer
   Dim i As Integer
   sRacine = Trim$(sRacine)
   If Len(sRacine) > 0 Then
      ReDim asDirs(0 To 0)
      If Right$(sRacine, 1) = "\" Then sRacine = Left$(sRacine, Len(sRacine) - 1)
      asDirs(0) = "\"
      Do While i <= UBound(asDirs)
         AddSubDirs sRacine, asDirs(i), asDirs
         i = i + 1
      Loop
      If i > 1 Then
         TriTableau asDirs
         GetSubDirs = i - 1
      End If
   End If
End Function

Fonctions secondaires appelées par la fonction principale

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
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
 
Private Sub AddSubDirs(ByVal sRacine As String, ByVal sSubDir As String, _
                            ByRef asDirs() As String)
   On Error GoTo errtag
   Dim sCurFileDir As String
   Dim iDims As Integer
   sRacine = sRacine & sSubDir
   iDims = UBound(asDirs) + 1
   sCurFileDir = Dir(sRacine, vbDirectory)
   Do While sCurFileDir <> vbNullString
      If sCurFileDir <> "." And sCurFileDir <> ".." Then
         If (GetAttr(sRacine & sCurFileDir) And vbDirectory) = vbDirectory Then
            ReDim Preserve asDirs(0 To iDims)
            sCurFileDir = sSubDir & sCurFileDir
            asDirs(iDims) = sCurFileDir & "\"
            iDims = iDims + 1
         End If
      End If
      sCurFileDir = Dir
   Loop
   Exit Sub
errtag:
   Resume Next
End Sub
Private Sub TriTableau(ByRef asTab() As String)
   Dim i As Long, j As Long, lInc As Long, n As Long, lMin As Long
   Dim lLowerBound As Long, lUpperBound As Long
   Dim sRef As String
   lLowerBound = LBound(asTab)
   lUpperBound = UBound(asTab)
   n = lUpperBound - lLowerBound + 1
   lInc = 1
   While lInc < n
      lInc = lInc * 3 + 1
   Wend
   While lInc > 1
      lInc = lInc / 3
      lMin = lInc + lLowerBound
      For i = lMin To lUpperBound
         j = i
         sRef = asTab(i)
         Do While sRef < asTab(j - lInc)
            asTab(j) = asTab(j - lInc)
            j = j - lInc
            If j < lMin Then Exit Do
         Loop
         asTab(j) = sRef
      Next i
   Wend
End Sub

Utilisation :

Code :

1
2
3
4
5
6
7
8
 
   Dim asDirs() As String
   Dim i As Integer, iNbSubDirs As Integer
   iNbSubDirs = GetSubDirs("C:\Documents and Settings\", asDirs)
   For i = 1 To UBound(asDirs) '1 pour ne pas afficher le premier élément inutile
Debug.Print asDirs(i)
   Next i
Debug.Print iNbSubDirs

On obtient donc un tableau trié par ordre alphabétique des sous-répertoires qui peut servir pour alimenter un listbox par exemple.

Philippe