Wer kennt das nicht: Da liegen nun die MP3 Dateien in schönster
Ordnung auf der Festplatte, die Dateinamen sind alle gemäß den
persönlichen Vorgaben und nach dem Überspielen auf den MP3 Player
stellt sich heraus, dass die Dateinamen hierfür sehr unpraktisch sind.
Player, die bei der Navigation die Ordnerstruktur verwenden, bieten
oft nicht genug Platz im Display, um auf den ersten Blick den
Song zu erkennen.
Hier wäre es zum Beispiel hilfreich, die Tracknummer, den Titel
und dann erst den Interpreten im Dateinamen zu sehen. Vielleicht
gibt es auch noch andere Vorstellungen, je nachdem wie die Ordnerstruktur
aufgebaut ist.
Sicher gibt es dafür eine Menge Programme, die diese Aufgabe mehr
oder weniger komfortabel erledigen. Aber welches ist für diesen
Zweck das beste? Eines steht jedoch fest: die Dateien manuell
umzubenennen, ist die denkbar schlechteste Alternative.
Auf diesen Seiten stelle ich nun ein VBA-Programm vor, welches
genau diese Arbeit "halbautomatisch" erledigt. Halbautomatisch
deshalb, weil vor dem Speichern das Ergebnis als Vorschlag angezeigt
wird, noch geändert werden kann und erst dann auf Knopfdruck
gespeichert wird.
An dieser Stelle möchte ich meinen Dank all jenen aussprechen,
die unzählige Beiträge zu diesem Thema auf ihren Webseiten
vorgestellt haben. Immer da, wo ich nicht mehr weiter wusste,
habe ich Codeschnipsel übernommen und angepasst und hoffe, dass
für andere meine Seite nun genauso hilfreich ist.
Zu diesem Programm gibt es eine Readme-Datei, die ich allen
empfehle, die die
Excel-Datei
(als ZIP gepackt - 46 KB) herunterladen und als ganzes
ausprobieren möchten.
Modul1
Modul2
Modul3
CommandButtons
Menü
OK, die Readme ist noch nicht fertig. Ich arbeite gerade daran.
Ausserdem gibt es noch ein paar nötige Nachbesserungen:
- Wenn es mehr, als einen Punkt im Dateinamen gibt
- Trennzeichen ohne Leerzeichen davor und/oder dahinter
Das sind aber nur Kleinigkeiten.
- Ein kleiner Bug in der Menükontrolle wurde beseitigt
Screenshot1
Screenshot2
Screenshot3
Option Explicit
Function ID_TAG_auslesen(Tagname As String, Ueberschrift As String) ' Autor: Hubert Scheidgen 07.2007 Dim b As Byte, Zeile As Byte, Spalte As Byte, i As Long Dim TagInhalt As String Dim Pfad As String, Datei As String, TN As String Dim Knz As String * 4 'Tagheader Dim ID3Knz As String * 3 'die ersten 3 Bytes eines ID3v2 Containers Dim Leseposition As Long Dim ID3Laenge As String * 4 'ID3v2 Länge im ASCII Format Dim lngID3Laenge As Long 'ID3v2 Grösse in Bytes (=Anzahl Bytes in Dezimal-Form) 'Dim Beite(1 To 4) As Long Dim Ende As Long 'Dim Spaltennummer As Integer On Error GoTo Fehler If ActiveSheet.Index <> 1 Then MsgBox ("falsches Arbeitsblatt ausgewählt") Exit Function End If Spalte = ActiveCell.Cells.Column Pfad = Worksheets(3).Range("A1").Value & "\" 'Spalte = Spaltennummer Zeile = 2 Tagname = UCase(Tagname) Do Until IsEmpty(Worksheets(2).Range("A" & Zeile)) = True Datei = Pfad & Worksheets(2).Range("A" & Zeile).Value Open Datei For Binary Access Read As #1 Get #1, 1, ID3Knz If ID3Knz = "ID3" Then 'ID3v2 Containerlänge feststellen Get #1, 7, ID3Laenge 'Beite(1) = Asc(Left$(ID3Laenge, 1)) 'Beite(2) = Asc(Mid$(ID3Laenge, 2, 1)) 'Beite(3) = Asc(Mid$(ID3Laenge, 3, 1)) 'Beite(4) = Asc(Mid$(ID3Laenge, 4, 1)) 'lngID3Laenge = (&H200000 * Beite(1)) + _ '(&H4000 * Beite(2)) + (&H80 * Beite(3)) + Beite(4) lngID3Laenge = CLng(&H200000) * Asc(Left$(ID3Laenge, 1)) + _ CLng(&H4000) * Asc(Mid$(ID3Laenge, 2, 1)) + _ CLng(&H80) * Asc(Mid$(ID3Laenge, 3, 1)) + _ Asc(Mid$(ID3Laenge, 4, 1)) Leseposition = 11 ' Do Until Leseposition > lngID3Laenge 'FrmLng = 0 Ende = 0 Get #1, Leseposition, Knz If UCase(Knz) = Tagname Then Ende = Framegroesse(Leseposition) - 1 Seek 1, Leseposition + 4 + 7 b = "0" For i = 1 To Ende Get #1, , b TagInhalt = TagInhalt & Chr(b) Next i 'Close #1 If Len(TagInhalt) = 1 And UCase(Tagname) = "TRCK" Then TagInhalt = "0" & TagInhalt End If Worksheets("Tabelle1").Cells(Zeile, Spalte).Value = Trim(TagInhalt) 'Worksheets("Tabelle1").Range("B" & Zeile).Value = lngID3Laenge TagInhalt = Empty Exit Do Else 'auslesen der Framegrösse Leseposition = Leseposition + 10 + Framegroesse(Leseposition) End If Loop Close #1 Else Close #1 End If 'Close #1 TN = Empty Zeile = Zeile + 1 Loop Worksheets("Tabelle1").Cells(1, Spalte).Value = Ueberschrift Worksheets(1).Range("A:D").Columns.AutoFit MsgBox ("Auslesen des ID3v2 Tags beendet") Fehler: 'Close #1 End Function
Function Framegroesse(Leseposition) Dim i As Integer Dim b As Byte Dim FrmLng As String * 4 'Framelänge im ASCII Format Dim lngFrmLng As Long 'Framegrösse in Bytes (=Anzahl Bytes in Dezimal-Form) Dim Beite(1 To 4) As Long ' For i = 0 To 3 ' Get #1, Leseposition + 4 + i, b ' Next i Get #1, Leseposition + 4, FrmLng Beite(1) = Asc(Left$(FrmLng, 1)) Beite(2) = Asc(Mid$(FrmLng, 2, 1)) Beite(3) = Asc(Mid$(FrmLng, 3, 1)) Beite(4) = Asc(Mid$(FrmLng, 4, 1)) lngFrmLng = &H10000 * Beite(1) + _ &H1000 * Beite(2) + &H100 * Beite(3) + Beite(4) 'Leseposition = Leseposition + 10 + lngFrmLng Framegroesse = lngFrmLng End Function
Function Teil_auslesen(Art As String, ES As Byte, TN As Boolean) Dim i As Byte Dim TZ As String 'Trennzeichen Dim Text As String 'Dateiname oder Teil daraus Dim DE As String 'Dim haedertext As String TZ = Worksheets(3).Range("B2").Value On Error GoTo weiter1 i = 2 Do Until IsEmpty(Worksheets(2).Range("A" & i)) = True Text = Worksheets(2).Range("A" & i).Value DE = LCase(Right(Text, 3)) 'Dateiendung Worksheets(1).Cells(i, 4).Value = DE 'Dateiendung Select Case Art Case "1" Text = Trim(Left(Text, InStr(Text, TZ) - 1)) Case "2;3" Text = Trim(Right(Text, Len(Text) - (InStr(Text, TZ)))) Text = Trim(Left(Text, InStr(Text, TZ) - 1)) Case "3;3" Text = Trim(Right(Text, Len(Text) - (InStr(Text, TZ)))) Text = Trim(Right(Text, Len(Text) - (InStr(Text, TZ)))) Text = Trim(Left(Text, InStr(Text, ".") - 1)) Case "2;2" Text = Trim(Right(Text, Len(Text) - (InStr(Text, TZ)))) Text = Trim(Left(Text, InStr(Text, ".") - 1)) End Select If TN = True And Len(Text) = 1 Then Text = "0" & Text End If Worksheets(1).Cells(i, ES).Value = Text weiter1: Text = Empty i = i + 1 Loop i = Empty ES = Empty Art = Empty TN = False End Function
Function Headertext(Anweisung As String) Dim Spaltenkopf(1 To 3) 'Dim i As Byte Spaltenkopf(1) = "TrackNr." Spaltenkopf(2) = "Interpret" Spaltenkopf(3) = "Titel" Worksheets(1).Cells(1, 1).Value = Spaltenkopf(Left(Anweisung, 1) * 1) Worksheets(1).Cells(1, 2).Value = Spaltenkopf(Mid(Anweisung, 2, 1) * 1) Worksheets(1).Cells(1, 3).Value = Spaltenkopf(Mid(Anweisung, 3, 1) * 1) Worksheets(1).Cells(1, 4).Value = "Endung" Worksheets(1).Range("A:D").Columns.AutoFit End Function