Lecture des chemins de fichier à partir de dossiers et de sous-dossiers dans Excel

Question

J'utilise le code suivant pour lire les noms de fichiers dans une feuille Excel, mais j'aimerais inclure des sous-dossiers et capturer le chemin complet du fichier. J'ai essayé quelques petites choses mais aucune n'a fonctionné. J'ai bricolé cela ensemble à partir de morceaux de code d'autres personnes édités pour fonctionner dans ma situation, malheureusement cela signifie que ma compréhension n'est pas aussi approfondie qu'elle devrait l'être.

Les fichiers sont des fichiers audio (WAV ou MP3), le reste de la feuille de calcul contiendra des métadonnées qui seront utilisés pour marquer les fichiers: artiste, titre, album, etc.

Option Explicit 
Sub GetFileNames() 
Dim xRow As Long 
Dim xDirect$, xFname$, InitialFoldr$ 
InitialFoldr$ = "C:\" 

With Application.FileDialog(msoFileDialogFolderPicker) 
.InitialFileName = Application.DefaultFilePath & "\" 
.Title = "Please select the folder to list audio files from" 
.InitialFileName = InitialFoldr$ 
.Show 

    If .SelectedItems.Count <> 0 Then 
    xDirect$ = .SelectedItems(1) & "\" 
    xFname$ = Dir(xDirect$, 7) 
    Do While xFname$ <> "" 
    Worksheets("Metadata").Activate 
    ActiveSheet.Range("A2").Select 
    ActiveCell.Offset(xRow) = xFname$ 
    xRow = xRow + 1 
    xFname$ = Dir 
    Loop 

    Dim x& 
    With Application 
      .ScreenUpdating = False 
      Rows.Hidden = False 
      Rows.Hidden = True 
     For x = 1 To Rows.Count 
      If .WorksheetFunction.CountA(Rows(x)) > 0 Then Rows(x).Hidden = False 
     Next x 
     .ScreenUpdating = False 
    End With 

    Worksheets("Metadata").Visible = True 
    Worksheets("Menu").Visible = False 

End If 
End With 
End Sub 

Je suis très nouveau à VBA mais je commence à saisir une partie de celui-ci.

Answer 1

Ce code va extraire tous les mp3 d'un dossier et tous ses sous-dossiers. Bonne chance avec la VBA!

Public Sub FindFiles() 
'you must add a reference to 'Microsoft Shell Controls And Automation' 

Dim shl As Shell32.Shell 
Dim fol As Shell32.Folder 
Dim row As Long 

Set shl = New Shell32.Shell 
Set fol = shl.Namespace("E:\CDs\") 
row = 1 

ProcessFolderRecursively fol, row 

End Sub 

Private Sub ProcessFolderRecursively(fol As Shell32.Folder, ByRef row As Long) 

Dim item As Shell32.FolderItem 
Dim fol2 As Shell32.Folder 

If Not fol Is Nothing Then 
    For Each item In fol.Items 
     If item.IsFolder Then 
      Set fol2 = item.GetFolder 
      ProcessFolderRecursively fol2, row 
     Else 
      'you might need to edit the criterion here 
      If item.Type = "MP3 Format Sound" Then 
       Cells(row, 1) = item.Path 
       row = row + 1 
      End If 
     End If 
    Next 
End If 

End Sub