Discussion :

[tyros25]

Bonjour à tous !

Je suis confronté à un petit problème qui sera surement résolu rapidement, mais je n'arrive clairement pas à comprendre comment faire.

J'ai ce code qui me permet de lister les répertoires et sous répertoires d'un dossier choisit :

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
Sub TousLesDossiers(LeDossier$, Idx As Long)
    Dim fso As Object, Dossier As Object
    Dim sousRep As Object, Flder As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
        Idx = Idx + 1
        Cells(Idx, 1).Value = Flder.Path
    Next
    'traitement récursif des sous dossiers
    For Each sousRep In Dossier.subfolders
        TousLesDossiers sousRep.Path, Idx
    Next sousRep
    Set fso = Nothing
End Sub                                               'fs
Sub test()
  TousLesDossiers "C:\Users\MOI\Desktop\", 0
End Sub

Cependant, je souhaiterais incrémenter une variable "NbSousRepertoire" qui me définira une limite sur le nombre de sous repertoires à lister (après avoir imposer cette limite of course)

En clair il me faudrait cela (ne faite pas attention à mes talents sous paint svp ^^) :


Quelqu'un saurait m'aider svp ?

Je pense que la solution est simpliste mais je n'y arrive pas (peut-être qu'une pause me serait utile ??)

Merci d'avance !!!

[Theze]

Bonjour,

Une piste en comptant les anti-slash dans le chemin avec Split() :

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
 
Sub TousLesDossiers(LeDossier$, Idx As Long, Limite As Integer)
    Dim fso As Object, Dossier As Object
    Dim sousRep As Object, Flder As Object
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set Dossier = fso.GetFolder(LeDossier)
 
    'examen du dossier courant
    For Each Flder In Dossier.subfolders
 
        If UBound(Split(Flder, "\")) < Limite + 1 Then
            Idx = Idx + 1
            Cells(Idx, 1).Value = Flder.Path
        End If
 
    Next
    'traitement récursif des sous dossiers
    For Each sousRep In Dossier.subfolders
 
        If UBound(Split(sousRep, "\")) < Limite + 1 Then
            TousLesDossiers sousRep.Path, Idx, Limite
        End If
 
    Next sousRep
 
    Set fso = Nothing
End Sub
 
Sub test()
  TousLesDossiers "C:\Users\MOI\Desktop\", 0, 2 '<--ici il y aura maximum 2 sous-dossiers
End Sub

[eriiic]

Bonjour,

Theze je crois que tu as oublié de tenir compte des "\" déjà présents.
Bon, je pense que tyros aurait trouvé mais tant que je suis là :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Sub test()
    Dim rep As String
    rep = "C:\Users\MOI\Desktop\"
    TousLesDossiers rep, 0, Len(rep) - Len(Replace(rep, "\", "")) - 1 + 2    '<--ici il y aura maximum 2 sous-dossiers
End Sub

eric

[kiki29]

Salut, affecter un bouton à la procédure Liste

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
Option Explicit
 
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim NbDossiers As Long
Dim NbDossiersOk As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Dim sDossierDep As String
Const NiveauMax As Long = 3
 
Sub Liste()
Dim sChemin As String
    sChemin = ThisWorkbook.Path & Application.PathSeparator
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin 
        .Title = "Sélectionner un Dossier"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            NbDossiers = 0: NbDossiersOk = 0
            QueryPerformanceCounter Dep
 
            ShDatas.Cells.Clear
            Application.ScreenUpdating = False
            sDossierDep = Right$(.SelectedItems(1), Len(.SelectedItems(1)) - InStrRev(.SelectedItems(1), "\"))
 
            LectureDossiers .SelectedItems(1), 0, True
            Application.ScreenUpdating = True
 
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
            Application.StatusBar = "Niveau : " & NiveauMax & "  Dossiers : " & NbDossiersOk & " / " & NbDossiers & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
        End If
    End With
End Sub
 
Private Sub LectureDossiers(ByVal DossierRacine As String, ByRef iRow As Long, ByVal bSousDossiers As Boolean)
Dim FSO As Scripting.FileSystemObject
Dim Dossier As Scripting.Folder
Dim SousDossier As Scripting.Folder
Dim Pos As Long, sDossier As String
 
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(DossierRacine)
 
    For Each SousDossier In Dossier.SubFolders
        If Niveau(SousDossier.Path) <= NiveauMax Then
            iRow = iRow + 1
            Pos = InStr(DossierRacine, sDossierDep)
            sDossier = Mid$(SousDossier, Pos, Len(SousDossier))
 
            With ShDatas
                .Cells(iRow, 1) = sDossier
                .Cells(iRow, 2) = SousDossier.Size
                .Cells(iRow, 3) = SousDossier.DateLastModified
            End With
            NbDossiersOk = NbDossiersOk + 1
        End If
        NbDossiers = NbDossiers + 1
        Application.StatusBar = "Niveau : " & NiveauMax & "  Dossiers : " & NbDossiersOk & " / " & NbDossiers
    Next SousDossier
 
    If bSousDossiers Then
        For Each SousDossier In Dossier.SubFolders
            LectureDossiers SousDossier.Path, iRow, True
        Next SousDossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Private Function Niveau(sDossier As String) As Long
Dim Ar() As String, Pos As Long
    Pos = InStr(sDossier, sDossierDep)
    sDossier = Mid$(sDossier, Pos, Len(sDossier))
    Ar = Split(sDossier, "\")
    Niveau = UBound(Ar)
End Function

[Theze]

Bonjour,

Eric, tu as raison, j'ai zappé ça, zut !

[tyros25]

Merci à tous,

La méthode de Theze et eriiic fonctionne parfaitement !
Et effectivement, il y avait bien un problème sur le comptage des "\"... mais ca n'empeche que j'aurais peut-etre pas trouvé le reste tout seul

Merci encore, je passe en résolu !