Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.misc
|
|||
|
|||
VBA 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Jululian & Excel | Excel Discussion (Misc queries) | |||
Excel Jululian | Excel Discussion (Misc queries) | |||
Excel Jululian | Excel Discussion (Misc queries) | |||
Excel Jululian | Excel Discussion (Misc queries) | |||
Excel Jululian | Excel Discussion (Misc queries) |