macro stopt wie kan dit controleren

[lsc.b]

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) = "Artist"
    Cells(1, 2) = "Album"
    Cells(1, 3) = "Title"
    Cells(1, 4) = "Genre"
    Cells(1, 5) = "Duration"
    Range("A1:E1").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
    ReDim Preserve Dirs(0 To NumDirs) As String
           Dirs(NumDirs) = PathAndName
           NumDirs = NumDirs + 1       'store found directories
          
        Else
            If UCase(Right(filename, 3)) = "MP3" Then
                Row = WorksheetFunction.CountA(Range("A:A")) + 1
                Cells(Row, 1) = FileInfo(currdir, filename, 20) 'artist
                Cells(Row, 2) = FileInfo(currdir, filename, 14) 'album
                Cells(Row, 3) = FileInfo(currdir, filename, 21) 'title
                Cells(Row, 4) = FileInfo(currdir, filename, 16) 'genre
                Cells(Row, 5) = FileInfo(currdir, filename, 27) 'duration
                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

als ik deze macro laat zoeken krijg ik een fout melding en bij foutopsporing staat hier een gele balk
If (GetAttr(PathAndName) And vbDirectory) = vbDirectory Then
hij heeft dan 2560 file`s gevonden en dat is nog geen kwart van wat ik heb
het zou ook leuk zijn als ik hier ook andere media bestanden kon vinden zoals wma,ogg
wie kan dit oplossen ik zie door de bomen het bos niet meer

 

[snb]

Download en installeer mediamonkey.
Gebruik geen code die je niet begrijpt.

 

[lsc.b]

dat is niet wat ik wil

 

[Rooie Darp]

Download en installeer mediamonkey.
Gebruik geen code die je niet begrijpt.

Beetje rare reactie voor het helpmij forum.

Kan het niet aan de MP3's liggen?
Bij mijn D directory loopt hij helemaal door, Bij C begint hij niet eens.

 

[lsc.b]

klopt bij mij is het ook opgelost het lag wel aan mp3 er zaten fout codeering tussen