Code werkt niet meer in Excel 2007..wat nu ?

[MrTinkertrain]

Onderstaande code is afkomstig van de welbekende Excel-goeroe John Walkenbach.
Hiermee is het mogelijk om een aantal eigenschappen van mp3-bestanden uit te lezen.
Tot voor kort heb ik Excel 2003 gebruikt en werkte onderstaande code als een zonnetje.

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("Selecteer een map met MP3-bestanden")
    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
                Exit Sub
            End If
            Row = 1
            Worksheets("Sheet1").Activate
            ActiveSheet.Cells.Clear
            With ActiveSheet.Range("A1:G1")
                .Value = Array("Volledig Pad", "Artiest", "Titel", "Album Titel", "Track No.", "Jaar", "Genre")
                .Font.Bold = True
            End With
            Application.ScreenUpdating = False
            For i = 1 To .FoundFiles.Count
                If i Mod (100) = 0 Then
                    DoEvents
                    Application.StatusBar = "Bezig met " & 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) = GetMP3TagInfo(.FoundFiles(i), 16) 'artiest
                    ActiveSheet.Cells(Row, 3) = GetMP3TagInfo(.FoundFiles(i), 10) 'titel
                    ActiveSheet.Cells(Row, 4) = GetMP3TagInfo(.FoundFiles(i), 17) 'album titel
                    ActiveSheet.Cells(Row, 5) = GetMP3TagInfo(.FoundFiles(i), 19) 'track no.
                    ActiveSheet.Cells(Row, 6) = GetMP3TagInfo(.FoundFiles(i), 18) 'jaar
                    ActiveSheet.Cells(Row, 7) = GetMP3TagInfo(.FoundFiles(i), 20) 'genre
                                        
                End If
            Next i
        End If
    End With

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 = "Selecteer een map met MP3-bestanden"
    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

Sinds enkele dagen ben ik overgestapt op Excel 2007 en nu werkt deze code niet meer.
Ik ben er ook achter waarom deze code niet meer werkt.
Application.Filesearch blijkt in Excel 2007 niet meer te worden ondersteund.
Ik heb zelf geprobeerd de code aan te passen om deze ook in Excel 2007 weer werkend te krijgen.
Mijn kennis van VBA is helaas (nog) te gering om hier uit te komen.

Is er iemand die mij op weg kan helpen ?
Bij voorbaat dank

 

[snb]

Suggestie: gebruik Mediamonkey en exporteer de gegevens naar een Excelbestand.
Alternatief voor application.filesearch is

createobject("scripting.filesystemobject").getfolder("C:\mp3files").files

 

[MrTinkertrain]

Suggestie: gebruik Mediamonkey en exporteer de gegevens naar een Excelbestand.
Alternatief voor application.filesearch is

createobject("scripting.filesystemobject").getfolder("C:\mp3files").files

Ga ik zeker eens mee stoeien, snb
Even een vraag nog :
Is de methode die jij voorstelt ook geschikt voor Excel 2003 ?

 

[snb]

Ja

 

[MrTinkertrain]

Ik heb vooralsnog Excel 2003 maar weer teruggezet.
Ben nog niet zo gecharmeerd van 2007
Maar ik ga zeker met je tip aan de slag, snb
Hartelijk dank voor je bijdrage.