Discussion :

[loranba]

Bonjour a tous,

Nouveau venu et plus que novice, j'ai récupéré un bout de code me permettant de récupérer dans un répertoire la liste des fichiers (mp3) afin d'obtenir les proprietes des fichiers (nom, debit, album, artist .......etc)

Mon problème est que ce code ne parcourt pas les sous-dossiers.
Par exemple, je ne peux pas lui faire scanner tous mon répertoire de MP3, je ne peux le faire que dans chaque répertoire de chaque album..... je ne sais pas si je suis clair ?


voici le code récupéré :

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
Private Sub CommandButton1_Click()
 Dim sPath As String: sPath = GetShellFolder
 If sPath = "" Then Exit Sub
 If Dir(sPath, vbDirectory) = "" Then Exit Sub
 Dim Headers(35), x%, y&, i&, p$, n$, oFile As Object
 Dim objShell As Object, oFolder As Object
 Set objShell = CreateObject("Shell.Application")
 Set oFolder = objShell.Namespace(CStr(sPath))
 Application.ScreenUpdating = False
 Workbooks.Add
 For i = 0 To 34
 Headers(i) = oFolder.GetDetailsOf(oFolder.Items, i)
 Select Case i
 Case 1 To 34
 x = x + 1
 Cells(1, x) = Headers(i)
 End Select
 Next
 y = 1
 For Each oFile In oFolder.Items
 p = oFile.Path: n = oFile.Name
 If Right$(n, 4) = ".mp3" Then
 x = 0: y = y + 1
 For i = 0 To 34
 Select Case i
 Case 1 To 34
 x = x + 1
 Cells(y, x) = oFolder.GetDetailsOf(oFile, i)
 With ActiveSheet
 .Hyperlinks.Add .Range("A" & y), Hlink(p), , n, n
 End With
 End Select
 Next
 End If
 Next
 Range("A2").Select
 ActiveWindow.FreezePanes = True
 Rows("1:1").Font.Bold = True
 Cells.Columns.AutoFit
 Range("A1").Select
 Set oFolder = Nothing: Set objShell = Nothing
 MsgBox "Fin de la récupération"
 UserForm1.Hide
 End Sub
 
 Private Function GetShellFolder() As String
 Const Title = "Sélectionnez un répertoire !"
 Dim oSHA As Object, oSF As Object, oItem As Object
 On Error GoTo 1
 Set oSHA = CreateObject("Shell.Application")
 Set oSF = oSHA.BrowseForFolder(0, Title, &H1 Or &H10, &H11)
 If InStr(TypeName(oSF), "Folder") <> 1 Then Exit Function
 For Each oItem In oSF.parentfolder.Items
 If oItem.Name = oSF.Title Then
 GetShellFolder = oItem.Path
 Exit Function
 End If
 Next
 GetShellFolder = oSF.Title
 Set oSF = Nothing: Set oSHA = Nothing
 Exit Function
1:  MsgBox "Error: " & Err.Number & vbLf & Err.Description, 48
 End Function
 
 Private Function Hlink(p As String) As String
 Hlink = "file:///" & Replace(Replace(p, " ", "%20"), "", "/")
 End Function

Merci d'avance pour votre aide je vais bientot m'arracher les cheveux ..... Aie !!

[kiki29]

Salut, voir ici avec une modif minime pour mp3
Le reste sera à adapter

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
Option Explicit
 
Declare Function QueryPerformanceCounter Lib "Kernel32" (X As Currency) As Boolean
Declare Function QueryPerformanceFrequency Lib "Kernel32" (X As Currency) As Boolean
 
Dim NbFichiers As Long, NbDossiers As Long
Dim Dep As Currency, Fin As Currency, Freq As Currency
Const TypeFichier As String = "mp3"
 
Private Sub Liste(ByVal sChemin As String, ByVal bSousDossier As Boolean)
Dim FSO As Object, Dossier As Object, SousDossier As Object, Fichier As String
 
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Dossier = FSO.GetFolder(sChemin)
 
    Fichier = Dir$(sChemin & "\*.*")
    Do While Len(Fichier) > 0
        If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
            NbFichiers = NbFichiers + 1
            With Feuil1
                .Cells(NbFichiers, 1) = sChemin
                .Cells(NbFichiers, 2) = Fichier
            End With
        End If
        Fichier = Dir$()
        Application.StatusBar = "Dossiers : " & NbDossiers & "  Fichiers : " & NbFichiers
    Loop
 
    If bSousDossier Then
        For Each Dossier In Dossier.SubFolders
            NbDossiers = NbDossiers + 1
            Liste Dossier.Path, True
        Next Dossier
    End If
 
    Set Dossier = Nothing
    Set FSO = Nothing
End Sub
 
Sub Tst()
Dim sChemin As String
    sChemin = ThisWorkbook.Path
    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
            Feuil1.Cells.Clear
            Application.ScreenUpdating = False
            Application.StatusBar = ""
            DoEvents
            QueryPerformanceCounter Dep
            NbFichiers = 0: NbDossiers = 0
 
            Liste .SelectedItems(1), True
 
            Application.ScreenUpdating = True
            QueryPerformanceCounter Fin: QueryPerformanceFrequency Freq
            Application.StatusBar = "Dossiers : " & NbDossiers & "  Fichiers : " & NbFichiers & " / " & Format(((Fin - Dep) / Freq), "0.00 s")
        End If
    End With
End Sub

PS: sorti des décombres, mais devrait correspondre à tes attentes
Affecter un bouton à SelDossier

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
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
'----------------------------------------------------------------------------
'   Outils / Références A COCHER  Microsoft Scripting Runtime
'                                 Microssoft Shell Controls and Automation
'----------------------------------------------------------------------------
Private Declare Function QueryPerformanceCounter Lib "Kernel32" (x As Currency) As Boolean
Private Declare Function QueryPerformanceFrequency Lib "Kernel32" (x As Currency) As Boolean
 
Option Explicit
 
Dim i As Long, k As Long
Dim oShell As Shell, oFolder As Shell32.Folder, oFolderItem As Shell32.FolderItem
Dim FSO As FileSystemObject, Dossier As Scripting.Folder, Fichier As Scripting.File
Dim Debut As Currency, Fin As Currency, Freq As Currency, NbDossiers As Long
Const TypeFichier As String = "mp3"
 
Private Sub ExtractionDonnees(sDossier As String)
Dim LastRow As Long, j As Long
    Application.ScreenUpdating = False
 
    With Feuil1
        .Cells.Clear
        .Range("A1") = "Nom"
        .Range("B1") = "Taille"
        .Range("C1") = "Type"
        .Range("D1") = "Date Modification"
        .Range("E1") = "Date Création"
        .Range("F1") = "Date Dernier Accès"
        .Range("G1") = "Attributs"
        .Range("H1") = "Etat"
        .Range("I1") = "Propriétaire"
        .Range("J1") = "Auteur"
        .Range("K1") = "Titre"
        .Range("L1") = "Sujet"
        .Range("M1") = "Catégorie"
        .Range("N1") = "Pages"
        .Range("O1") = "Commentaires"
        .Range("P1") = "Copyright"
        .Range("Q1") = "Artiste"
        .Range("R1") = "Titre Album"
        .Range("S1") = "Année"
        .Range("T1") = "N° de Piste"
        .Range("U1") = "Genre"
        .Range("V1") = "Durée"
        .Range("W1") = "Vitesse Transmission"
        .Range("X1") = "Protégé"
        .Range("Y1") = "Modele Appareil Photo"
        .Range("Z1") = "Date Cliché"
        .Range("AA1") = "Dimension"
        .Range("AB1") = "Largeur"
        .Range("AC1") = "Hauteur"
        .Range("AD1") = "Nom Episode"
        .Range("AE1") = "Description Programme"
        .Range("AF1") = "Taille Echantillon Audio"
        .Range("AG1") = "Fréquence Echantillonnage"
        .Range("AH1") = "Chemin"
    End With
 
    k = 2
 
    Set oShell = New Shell
    Set FSO = New Scripting.FileSystemObject
    Set Dossier = FSO.GetFolder(sDossier)
 
    NbDossiers = NbDossiers + 1
    For Each Fichier In Dossier.Files
        If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
            Set oFolder = oShell.NameSpace(Dossier.Path)
            Set oFolderItem = oFolder.ParseName(Fichier.Name)
            i = 1
            With Feuil1
                For j = 0 To 34
                    If j <> 31 Then
                        .Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
                        i = i + 1
                    End If
                Next j
                .Range(NumCol2Lettre(i - 1) & k) = sDossier
                Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 1
                k = k + 1
            End With
        End If
    Next Fichier
 
    RchRecursive Dossier
    FormatAttributs
 
    With Feuil1
        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:AH" & LastRow).WrapText = False
        .Range("1:1").Font.Bold = True
        .Rows("2:2").Select
        ActiveWindow.FreezePanes = True
 
        .Columns("A:AH").EntireColumn.AutoFit
        .Range("A1:AH1").Interior.ColorIndex = 36
        .Range("D2:F" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
        .Range("AF2:AF" & LastRow).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    End With
 
    Tri
 
    Feuil1.Activate
    With ActiveWindow
        .ScrollRow = 1
        .ScrollColumn = 1
    End With
 
    Set FSO = Nothing
    Set oShell = Nothing
    Set Dossier = Nothing
    Set oFolder = Nothing
    Set oFolderItem = Nothing
    Set Fichier = Nothing
 
    Application.ScreenUpdating = True
End Sub
 
Private Sub FormatAttributs()
Dim LastRow As Long
    LastRow = Feuil1.Range("G" & Rows.Count).End(xlUp).Row
    Feuil1.Range("G2:G" & LastRow).Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
    End With
End Sub
 
Private Function NumCol2Lettre(iNumCol As Long) As String
Dim i As Long, sStr As String
    i = iNumCol
    sStr = ""
    Do While i > 0
        sStr = Chr$(((i - 1) Mod 26) + 65) & sStr
        i = (i - 1) \ 26
    Loop
    NumCol2Lettre = sStr
End Function
 
Private Sub RchRecursive(sFolder As Scripting.Folder)
Dim SousDossier As Scripting.Folder
Dim j As Long
 
    For Each SousDossier In sFolder.SubFolders
        Set Dossier = FSO.GetFolder(SousDossier)
        NbDossiers = NbDossiers + 1
        For Each Fichier In SousDossier.Files
            If UCase$(TypeFichier) = UCase$(FSO.GetExtensionName(Fichier)) Then
                Set oFolder = oShell.NameSpace(Dossier.Path)
                Set oFolderItem = oFolder.ParseName(Fichier.Name)
                i = 1
                With Feuil1
                    For j = 0 To 34
                        If j <> 31 Then
                            .Range(NumCol2Lettre(i) & k) = oFolder.GetDetailsOf(oFolderItem, j)
                            i = i + 1
                        End If
                    Next j
                    .Range(NumCol2Lettre(i - 1) & k) = sFolder
                    k = k + 1
                End With
            End If
            Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k
        Next Fichier
 
        RchRecursive SousDossier
 
    Next SousDossier
End Sub
 
Sub SelDossier()
Dim sChemin As String
 
    sChemin = ThisWorkbook.Path
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = sChemin & "\"
        .Title = "Sélectionner le Dossier à traiter"
        .AllowMultiSelect = False
        .InitialView = msoFileDialogViewDetails
        .ButtonName = "Sélection Dossier"
        .Show
        If .SelectedItems.Count > 0 Then
            DoEvents
            QueryPerformanceCounter Debut
            NbDossiers = 0
            ExtractionDonnees .SelectedItems(1)
 
            QueryPerformanceCounter Fin
            QueryPerformanceFrequency Freq
 
            Application.StatusBar = "Dossiers : " & NbDossiers & " / Fichiers : " & k - 2 & " / " & Format((Fin - Debut) / Freq, "0.00 s")
        End If
        Feuil1.Range("C1").Select
    End With
End Sub
 
Private Sub Tri()
Dim LastRow As Long
    LastRow = Feuil1.Range("A" & Rows.Count).End(xlUp).Row
    Feuil1.Range("A2:AH" & LastRow).Sort Key1:=Feuil1.Range("A2"), Order1:=xlAscending, Key2:=Feuil1.Range("B2") _
                                                                                              , Order2:=xlAscending, Key3:=Feuil1.Range("C2"), Order3:=xlAscending, Header:= _
                                         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                                         DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:= _
                                         xlSortNormal
End Sub

PS : Suivant le système ( Vista et W7 ) la limite de j dans GetDetailsOf(oFolderItem, j) va au delà de 34

[loranba]

Bonjour Kiki29,

Trop top ton deuxieme code, effectivement cela correspond exactement a mon besoin. Je ne dirai qu'un mot, merci Monsieur !

Par contre petite remarque :
- Au bureau je suis sous XP, j'ai fait un test avec un album et j'ai bien les bonnes valeurs dans les bonnes colonnes ( nom de l'artiste dans la colonne artitste.
- A la maison je suis sous SEVEN et la c'est le drame car je n'ai pas les bonnes valeur dans les colonnes. ( la colonne artiste est vide mais le nom de l'artiste se retrouve dans la colonne Genre ou Pages )
As-tu une idées ? Y aurai t-il pas une différences dans le placement des propriétés des fichiers entre XP et SEVEN ?
==> Le Hic c'est que les MP3 que je dois lister sont chez moi et pas au travaill

Merci encore
Laurent

[kiki29]

Salut, effectivement c'est ce que je soupçonnais pour Vista et W7, je suis sous XP
A toi de faire la mise à jour

PS : Suivant le système ( Vista et W7 ) la limite de j dans GetDetailsOf(oFolderItem, j) va au delà de 34