music list

[kmorgan2004]

I found this marco on the web, but i dont have the shell32.dll on my work computer and my It guy want help me out. can i change up the marco so that it works on my excel. The line -Public objShell As IShellDispatch4- is where it is hanging up at.

Option Explicit
'Requires a reference to:
' Microsoft Shell Controls and Automation (shell32.dll)

'Uses techniques found here:
'http://www.microsoft.com/resources/documentation/windows/2000/server/scriptguide/en-us/sas_fil_lunl.mspx

Public objShell As IShellDispatch4

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

'32-bit 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


Sub DisplayMP3Info()
Dim i As Long
Dim Folder As String
Dim StrLen As Long, FolderLen As Long
Dim NameOnly As String
Dim Row As Long

' Prompt for the directory
Folder = GetDirectory("Select a directory that has MP3 files")
Set objShell = CreateObject("Shell.Application")

FolderLen = Len(Folder)
With Application.FileSearch
.NewSearch
.LookIn = Folder
.SearchSubFolders = True
.FileType = msoFileTypeAllFiles
If .Execute > 1 Then
If .FoundFiles.Count = 0 Then
MsgBox "Error - No files.", vbCritical
GoTo ExitSub
Exit Sub
End If
Row = 1
Worksheets("Sheet1").Activate
ActiveSheet.Cells.Clear
With ActiveSheet.Range("A1:K1")
.Value = Array("Path", "Filename", "Size", "Date/Time", "Artist", "Album Title", "Year", "Track No.", "Genre", "Duration", "Bit Rate")
.Font.Bold = True
End With
Application.ScreenUpdating = False
For i = 1 To .FoundFiles.Count
If i Mod (100) = 0 Then
DoEvents
Application.StatusBar = "Working on " & i & " of " & .FoundFiles.Count
End If
If Right(.FoundFiles(i), 3) = "mp3" Then
Row = Row + 1
'Parse the directory path to get genre, artist, and album name, and song title
ActiveSheet.Cells(Row, 1) = .FoundFiles(i)
ActiveSheet.Cells(Row, 2) = FileNameOnly(.FoundFiles(i))
ActiveSheet.Cells(Row, 3) = FileLen(.FoundFiles(i)) ' file size
ActiveSheet.Cells(Row, 4) = FileDateTime(.FoundFiles(i)) 'date
ActiveSheet.Cells(Row, 5) = GetMP3TagInfo(.FoundFiles(i), 16) 'artist
ActiveSheet.Cells(Row, 6) = GetMP3TagInfo(.FoundFiles(i), 17) 'album title
ActiveSheet.Cells(Row, 7) = GetMP3TagInfo(.FoundFiles(i), 18) 'year
ActiveSheet.Cells(Row, 8) = GetMP3TagInfo(.FoundFiles(i), 19) 'track number
ActiveSheet.Cells(Row, 9) = GetMP3TagInfo(.FoundFiles(i), 20) 'duration
ActiveSheet.Cells(Row, 10) = GetMP3TagInfo(.FoundFiles(i), 21) 'genre
ActiveSheet.Cells(Row, 11) = GetMP3TagInfo(.FoundFiles(i), 22) 'bit rate
End If
Next i
End If
End With
ExitSub:
'update the pivot table
ActiveSheet.UsedRange.Name = "Data"
Worksheets("pivot").PivotTables("PivotTable1").PivotCache.Refresh

Set objShell = Nothing
Application.StatusBar = False
End Sub

Function GetMP3TagInfo(FolderName, ItemNum)
Dim strFilename
Dim objFolder As Folder3
Dim objFolderItem As FolderItem2
Dim FileName As String

FileName = FileNameOnly(FolderName)
Set objFolder = objShell.Namespace(Left(FolderName, Len(FolderName) - Len(FileName)))
Set objFolderItem = objFolder.ParseName(FileName)
GetMP3TagInfo = objFolder.GetDetailsOf(objFolderItem, ItemNum)
End Function


Function FileNameOnly(FullPath) As String
Dim i As Long
Dim FN As String
If Right(FullPath, 1) = "\" Then FullPath = Left(FullPath, Len(FullPath) - 1)
For i = Len(FullPath) To 1 Step -1
If Mid(FullPath, i, 1) = "\" Then
FileNameOnly = FN
Exit Function
Else
FN = Mid(FullPath, i, 1) & FN
End If
Next i
End Function


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

 

[Juan Pablo González]

Are you sure you don't have that file? I would say that that file is one critical part of Windows (unless maybe you're running on a Mac?)
Mine is in

C:\WINDOWS\System32\Shell32.dll

 

[Joe Was]

Try this smaller version:


Sub myFileList(folderspec)
Dim fScript, myFolder, n, FFiles, myFList
'Folder Files List Function.
'Run from call sub, store in module.
Set fScript = CreateObject("Scripting.FileSystemObject")
Set myFolder = fScript.GetFolder(folderspec)
Set FFiles = myFolder.Files
For Each n In FFiles
myFList = myFList & n.Name
myFList = myFList & vbCrLf
Next
MsgBox myFolder & "" & myFList
End Sub

Sub Delete_Data()
'Delete the current screen print of file data.

Application.ScreenUpdating = False
Columns("A:A").Select
Selection.ClearContents
Range("A1").Select
Selection.EntireRow.Delete
Range("C1").Select
Application.ScreenUpdating = True
End Sub

Sub Look_For_MP3()
Dim lngCellCounter As Long
Dim Message, Title, Default, MyDir
'Search current directory for all files.

Application.ScreenUpdating = False
Message = "Enter the directory to search?" & Chr(13) & Chr(13) & "(Drive:\Directory\SubDirectory)" ' Set prompt.
Title = "Enter: Drive and Path!" ' Set title.
Default = "C:\" ' Set default.
' Display message, title, and default value.
On Error GoTo myErr

MyDir = InputBox(Message, Title, Default)

With Application.FileSearch
.NewSearch
.Filename = "*.MP3"
.LookIn = MyDir
.SearchSubFolders = True
If .Execute() > 0 Then

MsgBox "There were " & .FoundFiles.Count & " MP3 file(s) found."

For lngCellCounter = 1 To .FoundFiles.Count
Cells(lngCellCounter, 1) = .FoundFiles(lngCellCounter)
Sheets("Sheet1").Select
Next lngCellCounter

Range("A1").Select
Selection.EntireRow.Insert
Range("AA2").Select
Selection.Copy
Range("A1").Select
ActiveSheet.Paste
Else

MsgBox "No MP3's found!"
End If

End With
Application.ScreenUpdating = True
End
myErr:

MsgBox "No MP3's found!"

End Sub

 

[kmorgan2004]

I dont have a systems32\windows\ directory

i am running ms office. i downloaded the shell32.dll file where do i need to place it

 

[kmorgan2004]

Joe,
I was trying to use that macro to but 2 thing i only want .wav, .mp3,.mp4 to show up. I have some .db and .jpg that i dont want to show up. Also in some of my folders i dont have an album folder just songs. in the macro i expand the path to artist album and song. but in column B some songs show up since i dont have an ablum. how can i fix these problems. thanks

Sub trythis()
Dim Path As String

Range("A1:A65000").ClearContents
Path = "L:\music\"
With Application.FileSearch
.NewSearch
.LookIn = Path
.SearchSubFolders = True ' change as needed
.Filename = "*" ' Change as needed
.MatchAllWordForms = True
.FileType = msoFileTypeAllFiles ' change as needed
If .Execute(SortBy:=msoSortByFileName, SortOrder:=msoSortOrderAscending) > 0 Then
For i = 1 To .FoundFiles.Count
Cells(i, 1) = .FoundFiles(i) ' results in cell A[1-n]
Next i
Else
MsgBox "There were no files found."
End If
End With

On Error GoTo ErrHandler

Application.ScreenUpdating = False

Do
Row = Cells.Find(What:=".jpg", After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False).Row
Rows(Row).Delete Shift:=xlUp
Loop

ErrHandler:
Application.ScreenUpdating = True
Columns("A:B").Select
Selection.Font.ColorIndex = 0
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1)
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="\", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
1))
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Selection.ColumnWidth = 20.9
Selection.ColumnWidth = 29.5
Selection.ColumnWidth = 42.8
Selection.ColumnWidth = 55.4
Selection.ColumnWidth = 64.8
Columns("C:C").ColumnWidth = 17.4
Columns("A:C").Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Key2:=Range("B1") _
, Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
End Sub

 

[Scott Huish]

I dont have a systems32\windows\ directory

That's not what Juan Pablo Gonzalez said, what he said was:
C:\WINDOWS\System32\Shell32.dll

but in Windows 2000, it is in:
C:\WINNT\System32\Shell32.dll

 

[Von Pookie]

I don't know if it's any help to those that are *trying* to help, but the code the OP posted is that of JWalk's mp3 lister (which is free and not protected so posting the code is not a problem, for the record):

http://j-walk.com/ss/excel/tips/tip103.htm

 

[kmorgan2004]

The J-walker marco stops on the line

Public objShell As IShellDispatch4

What do i need to do to fix this.

 

[Norie]

Change this.

Public objShell As IShellDispatch4

to this.

Public objShell As Object

 

[Juan Pablo González]

You would need to change these two as well:

Dim objFolder As Folder3
Dim objFolderItem As FolderItem2