AW: Laufzeit von mp3 Dateien auslesen
23.09.2010 22:15:43
mp3
Hallo Carten,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand _
As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As _
Long) As Long
Sub list_MP3()
Dim objFiles() As Object, lngRet As Long, lngIndex As Long
Dim strPath As String, vntValues() As Variant
strPath = "E:\Musik" 'Verzeichnis - Anpassen!
Cells.Clear
lngRet = FileSearchINFO(objFiles, strPath, "*.mp3", True)
If lngRet > 0 Then
Redim vntValues(1 To lngRet + 1, 1 To 3)
vntValues(1, 1) = "Verzeichnis"
vntValues(1, 2) = "Name"
vntValues(1, 3) = "Dauer"
For lngIndex = 0 To lngRet - 1
vntValues(lngIndex + 2, 1) = objFiles(lngIndex).ParentFolder.Path
vntValues(lngIndex + 2, 2) = objFiles(lngIndex).Name
vntValues(lngIndex + 2, 3) = GetMP3Length(CStr(objFiles(lngIndex)))
Next
End If
Range("A1").Resize(UBound(vntValues, 1), UBound(vntValues, 2)) = vntValues
Rows(1).Font.Bold = True
Columns(3).NumberFormat = "h:mm:ss.00;@"
Columns.AutoFit
End Sub
Private Function FileSearchINFO(ByRef Files() As Object, ByVal InitialPath As String, Optional ByVal FileName As String = "*", _
Optional ByVal SubFolders As Boolean = False) As Long
'# PARAMETERINFO:
'# Files: Datenfeld zur Ausgabe der Suchergebnisse
'# InitialPath: String der das zu durchsuchende Verzeichnis angibt
'# FileName: String der den gesuchten Dateityp oder Dateinamen enthält (Optional, Standard="*.*" findet alle Dateien)
'# Beispiele: "*.txt" - Findet alle Textdateien
'# "*name*" - Findet alle Dateien mit "name" im Dateinamen
'# "*.avi;*.mpg" - Findet .avi und .mpg Dateien (Dateitypen mit ; trennen)
'# SubFolders: Boolean gibt an, ob Unterordner durchsucht werden sollen (Optional, Standard=False)
Dim fobjFSO As Object, ffsoFolder As Object, ffsoSubFolder As Object, ffsoFile As Object
Dim intC As Integer, varFiles As Variant
Set fobjFSO = CreateObject("Scripting.FileSystemObject")
Set ffsoFolder = fobjFSO.GetFolder(InitialPath)
On Error GoTo ErrExit
If InStr(1, FileName, ";") > 0 Then
varFiles = Split(FileName, ";")
Else
Redim varFiles(0)
varFiles(0) = FileName
End If
For Each ffsoFile In ffsoFolder.Files
If Not ffsoFile Is Nothing Then
For intC = 0 To UBound(varFiles)
If LCase(fobjFSO.GetFileName(ffsoFile)) Like LCase(varFiles(intC)) Then
If IsArray(Files) Then
Redim Preserve Files(UBound(Files) + 1)
Else
Redim Files(0)
End If
Set Files(UBound(Files)) = ffsoFile
Exit For
End If
Next
End If
Next
If SubFolders Then
For Each ffsoSubFolder In ffsoFolder.SubFolders
FileSearchINFO Files, ffsoSubFolder, FileName, SubFolders
Next
End If
If IsArray(Files) Then FileSearchINFO = UBound(Files) + 1
ErrExit:
Set fobjFSO = Nothing
Set ffsoFolder = Nothing
End Function
Private Function GetMP3Length(ByVal FileName As String) As Double
'source: http://www.vbarchiv.net/tipps/tipp_2071-laenge-spieldauer-einer-mp3-datei-ermitteln.html
Dim sReturn As String * 256
Dim lRet As Integer
mciSendString "open " & Chr(34) & FileName & Chr(34) & _
" type MPEGVideo alias mp3audio", 0, 0, 0
lRet = mciSendString("status mp3audio length", _
sReturn, Len(sReturn), 0&)
mciSendString "close mp3audio", 0, 0, 0
GetMP3Length = Val(sReturn) / 1000 / 86400
End Function
Gruß Sepp