Discussion :

[patinator3182]

Bonsoir,

J'ai pas mal avance grâce à "Parmi" utilisateur expert sur le forum, mais je bloque encore sur un Point:

- J'aimerai que les sous dossier n'apparaisse pas dans la liste et que le nombre de fichier soit cumuler au niveau du dossier analyse, ainsi que la dernière date de modification dans le dossier soit afficher sur la linge.

exemple

Toto 1048 150 08/10/2015

Merci beaucoup, je joints les modifs apportait dans le home2.zip.

Encore merci.

Patinator

---

Fichiers joints dans les discussions

---

[SfJ5Rpw8]

Bonjour,

utilise les balises de [code] [/code] pour poster la partie de ton code qui te cause problème ..

[patinator3182]

Bonsoir,

Je débute sur le forum, toutes mes excuse.

Alors voici le code, j'aimerai que tout sois centraliser au niveau du répertorie analyser, mais je n'y arrive pas.

Merci pour votre aide..

Patinator

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
 
 
Dim CheminDepart As String
 
Sub Depart()
    Dim objShell As Object, objFolder As Object, oFolderItem As Object
    Dim Chemin As String, Fichier
 
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
 
    If objFolder Is Nothing Then Exit Sub
 
    Set oFolderItem = objFolder.Items.Item
    Chemin = oFolderItem.Path & "\"
    CheminDepart = Chemin       'Pour enlever du nom affiché
 
 
    ListerRépertoiresPrincipaux Chemin
 
End Sub
 
Sub ListerRépertoiresPrincipaux(Chemin As String)
    Dim I As Long
    Dim Rep As Variant
    Dim Tablo
    Dim Idx As Long
 
    ReDim Tablo(Idx)
 
    Rep = Dir(Chemin, vbDirectory)
    Do While Rep <> ""
        'Stocke le répertoire
        If GetAttr(Chemin & Rep) = vbDirectory Then
            If Left(Rep, 1) <> "." Then
                ReDim Preserve Tablo(Idx)
                Tablo(Idx) = Chemin & Rep
                Idx = Idx + 1
            End If
        End If
 
        Rep = Dir
    Loop
 
    'Lit chaque répertoire trouvé
    For I = 0 To UBound(Tablo)
        ListerFichier Tablo(I)
    Next
 
End Sub
 
Sub ListerFichier(Chemin As Variant)
    Dim Fichier As Variant
    Dim Coll As Collection
    Dim Ligne As Long
    Dim Nom As String
    Dim Taille As Long
    Dim nbFichiers As Long
    Dim dDate As Date
 
    On Error GoTo Erreur
 
    Ligne = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1
 
    Set Coll = New Collection
 
    dDate = FileDateTime(Chemin)
    If Right(Chemin, 1) <> "\" Then Chemin = Chemin & "\"
 
    Fichier = Dir(Chemin, vbDirectory + vbArchive)
    Do While Fichier <> ""
        'Stocke le sous-répertoire
        If GetAttr(Chemin & Fichier) = vbDirectory Then
            If Left(Fichier, 1) <> "." Then
                Coll.Add Chemin & Fichier
            End If
 
        'Cumule les données
        ElseIf GetAttr(Chemin & Fichier) = vbArchive Then
            nbFichiers = nbFichiers + 1
            If FileDateTime(Chemin & Fichier) > dDate Then dDate = FileDateTime(Chemin & Fichier)
            Taille = Taille + FileLen(Chemin & Fichier)
        End If
        Fichier = Dir
    Loop
 
    'Inscrit les données
    ActiveSheet.Range("A" & Ligne) = Replace(Chemin, CheminDepart, "")
    ActiveSheet.Range("B" & Ligne) = CLng(Taille / 1000)  ' en Ko
    ActiveSheet.Range("C" & Ligne) = nbFichiers
    ActiveSheet.Range("D" & Ligne) = dDate
 
    For Each Fichier In Coll
        ListerFichier Fichier
    Next
 
    Set Coll = Nothing
 
    Exit Sub
 
Erreur:
    MsgBox Err.Number & vbCrLf & Err.Description
 
End Sub