VBA Jululian

[George A. Jululian]

Hi,

please find below a macro i use to find MP3 songs on C drive

i need help to amend this micro to find out all excel workbook (XLS) or
document (DOC) on all c;d;f;h drive

please help


Option Explicit
' By John Walkenbach
' Maybe be distributed freely, but not sold

'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