Liste ergänzen, nicht neu erstellen
CarVogt
Mit folgendem Makro Liste ich alle Ordner im Hauptverzeichnis inkl. der Spieldauer der enthaltenen mp3's auf.
Leider habe ich einen recht alten Rechner und das Makro läuft etwa 45 Minuten.
Was muss ich ändern, damit nur noch die neu hinzugekommenen Ordner eingefügt werden?
Dim dauer
Dim i As Long
Sub mp3_dateien_auflisten()
Dim objShell, objFolder
Dim BrowseDir, varName, datum
Set objShell = CreateObject("Shell.Application")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set BrowseDir = objShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
If Not BrowseDir Is Nothing Then
i = 1
Cells.Clear
Columns("F:F").NumberFormat = "[h]:mm:ss;@"
Application.ScreenUpdating = False
For Each o1 In FSO.GetFolder(BrowseDir.Items().Item().Path).SubFolders
dauer = CDate("00:00:00")
Cells(i, 1) = o1.Name
If (FSO.FileExists(o1 & "\Details.txt")) Then
j = 2
Set DieDatei = FSO.OpenTextFile(o1 & "\Details.txt", 1, False)
Do While DieDatei.AtEndOfStream True
Cells(i, j) = DieDatei.ReadLine
j = j + 1
Loop
DieDatei.Close
End If
dauer_ermitteln (o1)
Cells(i, 6) = dauer
i = i + 1
Next
End If
Columns.AutoFit
Application.ScreenUpdating = True
Set objShell = Nothing
End Sub
Function dauer_ermitteln(ordner)
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(ordner)
On Error Resume Next
For Each varName In objFolder.Items
If varName.Type "Dateiordner" And InStr(1, varName.Type, "MP3-Audio") 0 Then
For j = 0 To 51
If objFolder.GetDetailsOf(, j) = "Dauer" Then
dauer = dauer + CDate(Trim(objFolder.GetDetailsOf(varName, j)))
If Err.Number 0 Then
Debug.Print varName & vbTab & Trim(objFolder.GetDetailsOf(varName, j))
Err.Clear
End If
Exit For
End If
Next
ElseIf varName.Type = "Dateiordner" Then
dauer_ermitteln (varName.Path)
End If
Next
Set objFolder = Nothing
End Function
Gruß
Carsten