Option Explicit

'API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
  Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
  
Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfn As Long
  lParam As Long
  iImage As Long
End Type

Sub GetAllFiles()
    Dim Msg As String
    Dim Directory As String
    Msg = "Select the directory that contains the MP3 files. All subdirectories will be included."
    Directory = GetDirectory(Msg)
    If Directory = "" Then Exit Sub
    If Right(Directory, 1) <> "\" Then Directory = Directory & "\"
    Worksheets("Sheet1").Activate
    Cells.Clear
    Call RecursiveDir(Directory)
End Sub

Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
'   Root folder = Desktop
    bInfo.pidlRoot = 0&
'   Title in the dialog
    If IsMissing(Msg) Then
        bInfo.lpszTitle = "Select a folder."
    Else
        bInfo.lpszTitle = Msg
    End If
'   Type of directory to return
    bInfo.ulFlags = &H1
'   Display the dialog
    x = SHBrowseForFolder(bInfo)
'   Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        GetDirectory = Left(path, pos - 1)
    Else
        GetDirectory = ""
  End If
End Function


Public Sub RecursiveDir(ByVal currdir As String)
    Dim Dirs() As String
    Dim NumDirs As Long
    Dim filename As String
    Dim PathAndName As String
    Dim i As Long
    Dim Row As Long

'   Make sure path ends in backslash
    If Right(currdir, 1) <> "\" Then currdir = currdir & "\"

    Application.ScreenUpdating = False

'   Put column headings on active sheet
    Cells(1, 1) = "Path"
    Cells(1, 2) = "Filename"
    Cells(1, 3) = "Artist"
    Cells(1, 4) = "Album"
    Cells(1, 5) = "Title"
    Cells(1, 6) = "Track#"
    Cells(1, 7) = "Genre"
    Cells(1, 8) = "Duration"
    Cells(1, 9) = "Size"
    Range("A1:I1").Font.Bold = True
    
'   Get files
    filename = Dir(currdir & "*.*", vbDirectory)
    Do While Len(filename) <> 0
      If Left$(filename, 1) <> "." Then 'Current dir
        PathAndName = currdir & filename
        If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
          'store found directories
           ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1
        Else
            If UCase(Right(filename, 3)) = "MP3" Then
                Row = WorksheetFunction.CountA(Range("A:A")) + 1
                Cells(Row, 1) = currdir 'path
                Cells(Row, 2) = filename 'filename
                Cells(Row, 3) = FileInfo(currdir, filename, 20) 'artist
                Cells(Row, 4) = FileInfo(currdir, filename, 14) 'album
                Cells(Row, 5) = FileInfo(currdir, filename, 21) 'title
                Cells(Row, 6) = FileInfo(currdir, filename, 26) 'track
                Cells(Row, 7) = FileInfo(currdir, filename, 16) 'genre
                Cells(Row, 8) = FileInfo(currdir, filename, 27) 'duration
                Cells(Row, 9) = Application.Round(FileLen(currdir & filename) / 1024, 0) 'size
                Application.StatusBar = Row
            End If
        End If
    End If
        filename = Dir()
    Loop
    ' Process the found directories, recursively
    For i = 0 To NumDirs - 1
        RecursiveDir Dirs(i)
    Next i
    Application.StatusBar = False
End Sub

Function FileInfo(path, filename, item) As Variant
    Dim objShell As IShellDispatch4
    Dim objFolder As Folder3
    Dim objFolderItem As FolderItem2

    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.Namespace(path)
    Set objFolderItem = objFolder.ParseName(filename)
    FileInfo = objFolder.GetDetailsOf(objFolderItem, item)
    
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
End Function