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
Sub umwandeln_in_GK_Schreibung() ' Autor: Hubert Scheidgen 07.2007 Dim Zelle As Range Dim x As String Dim i, TL As Integer 'Zähler, Textlänge For Each Zelle In Selection TL = Len(Zelle) x = Zelle.Value x = UCase(Mid(x, 1, 1)) & Mid(x, 2, Len(x) - 1) For i = 2 To TL If Mid(x, i - 1, 1) = " " Then x = Left(x, i - 1) & UCase(Mid(x, i, 1)) & Mid(x, i + 1, TL - i) Else x = Left(x, i - 1) & LCase(Mid(x, i, 1)) & Mid(x, i + 1, TL - i) End If Next i Zelle.Value = x Next Zelle End Sub
Sub DNE_ETZ_true() 'Dateinamen erstellen Dim erstesTrennzeichen As Boolean erstesTrennzeichen = True Call Dateinamen_erstellen(erstesTrennzeichen) End Sub
Sub DNE_ETZ_false() 'Dateinamen erstellen Dim erstesTrennzeichen As Boolean erstesTrennzeichen = False Call Dateinamen_erstellen(erstesTrennzeichen) End Sub
Sub Dateinamen_erstellen(ETZ) 'Dim ETZ As Boolean 'erstesTrennzeichen Dim DN As String 'Dateinahme Dim Teil(1 To 3) As String 'Tracknummer, Interpret, Titel Dim TZ As String 'Trennzeichen Dim TZ1 As String 'Trennzeichen Dim i As Byte ' Zähler Dim DE As String 'Dateiendung 'Debug.Print ATZ TZ = Worksheets(3).Range("B2").Value TZ1 = " " & TZ & " " i = 2 With Worksheets(1) Do Until IsEmpty(.Range("A" & i)) = True DE = .Range("D" & i).Value Teil(1) = .Range("A" & i).Value Teil(2) = .Range("B" & i).Value Teil(3) = .Range("C" & i).Value DE = "." & .Range("D" & i).Value If ETZ = True Then DN = Teil(1) & TZ1 & Teil(2) & TZ1 & Teil(3) & DE With Worksheets(2) If Len(.Range("A" & i)) <> Len(DN) Then .Range("E" & i) = "!!!" Else .Range("E" & i) = "ok" End If End With ElseIf ETZ = False Then DN = Teil(1) & " " & Teil(2) & TZ1 & Teil(3) & DE With Worksheets(2) If Len(.Range("A" & i)) <> Len(DN) + 2 Then .Range("E" & i) = "!!!" Else .Range("E" & i) = "ok" End If End With End If Worksheets(2).Range("B" & i).Value = DN i = i + 1 Loop End With i = Empty DE = Empty DN = Empty Call Trennzeichen_zaehlen_1("B", "D") Worksheets(2).Activate Range("A1").Select End Sub
Sub Dateinamen_auslesen() 'Dateinamen in einem bestimmten Verzeichnis auflisten 'Die Angabe des Verzeichnises erfolgt in DOS Konvention 'Eingefügt werden die Daten ab der aktiven Zelle Dim Dateiname, Pfad, DE As String, i As Integer Pfad = Worksheets(3).Range("A1").Value If Pfad = Empty Then MsgBox ("zuerst Pfad in Tabelle 3 A1 eintragen") Exit Sub End If Dateiname = Dir$(Pfad & "\*.*") 'Hier Verzeichnis und Datei angeben i = 2 Do While Dateiname <> "" Worksheets(2).Range("A" & i) = Dateiname i = i + 1 Dateiname = Dir$() Loop i = Empty i = 2 With Worksheets(2) Do Until IsEmpty(.Range("A" & i)) = True DE = Right(.Range("A" & i), 3) If DE <> "mp3" And DE <> "wav" And DE <> "mid" _ And DE <> "ogg" Then .Range("A" & i).EntireRow.Delete i = i - 1 End If i = i + 1 Loop End With Worksheets(2).Activate Range("A1").Select Call Trennzeichen_zaehlen_1("A", "C") End Sub
Sub Dateien_umbenennen() ' oder: Speichern der neuen Dateinamen mit der Methode "Name DateinameAlt As DateinameNeu" Dim DA 'Dateiname alt Dim DN 'Dateiname neu Dim i As Byte Dim Pfad As String If Worksheets(3).Range("A1").Value = "" Then MsgBox ("zuerst Pfad in Tabelle 3 A1 eintragen") Exit Sub End If Pfad = Worksheets(3).Range("A1").Value i = 2 With Worksheets(2) Do Until IsEmpty(.Range("A" & i)) = True DA = .Range("A" & i).Value DN = .Range("B" & i).Value On Error Resume Next Name Pfad & "\" & DA As Pfad & "\" & DN i = i + 1 Loop End With i = Empty End Sub
Sub Drei_aa() ' von Interpret - Titel - Tracknummer ' nach Tracknummer - Interpret - Titel Call Teil_auslesen("1", 2, False) 'Interpret auslesen Call Teil_auslesen("2;3", 3, False) 'Titel auslesen Call Teil_auslesen("3;3", 1, True) 'Tracknummer auslesen Call Headertext("123") Worksheets(1).Activate Range("A1").Select End Sub
Sub Drei_ba() ' von Interpret - Tracknummer - Titel ' nach Tracknummer - Interpret - Titel Call Teil_auslesen("1", 2, False) 'Interpret auslesen Call Teil_auslesen("2;3", 1, True) 'Tracknummer auslesen Call Teil_auslesen("3;3", 3, False) 'Titel auslesen Call Headertext("123") Worksheets(1).Activate Range("A1").Select End Sub
Sub Drei_ca() ' von Tracknummer - Titel - Interpret ' nach Tracknummer - Interpret - Titel Call Teil_auslesen("1", 1, True) 'Tracknummer Call Teil_auslesen("2;3", 3, False) 'Titel auslesen Call Teil_auslesen("3;3", 2, False) 'Interpret auslesen Call Headertext("123") Worksheets(1).Activate Range("A1").Select End Sub
Sub Drei_da() ' von Tracknummer - Interpret - Titel ' nach Interpret - Titel - Tracknummer Call Teil_auslesen("1", 3, True) 'Tracknummer auslesen Call Teil_auslesen("2;3", 1, False) 'Interpret auslesen Call Teil_auslesen("3;3", 2, False) 'Titel auslesen Call Headertext("231") Worksheets(1).Activate Range("A1").Select End Sub
Sub Drei_db() ' von Tracknummer - Interpret - Titel ' nach Tracknummer - Titel - Interpret Call Teil_auslesen("1", 1, True) 'Tracknummer auslesen Call Teil_auslesen("2;3", 3, False) 'Interpret auslesen Call Teil_auslesen("3;3", 2, False) 'Titel auslesen Call Headertext("132") Worksheets(1).Activate Range("A1").Select End Sub
Sub Drei_ea() ' von Interpret - Titel ' nach Tracknummer (manuell) - Interpret - Titel Call Teil_auslesen("1", 2, False) 'Interpret auslesen Call Teil_auslesen("2;2", 3, False) 'Titel auslesen Call Headertext("123") Worksheets(1).Activate Range("A1").Select End Sub
Sub Drei_fa() ' von Titel - Interpret ' nach Tracknummer (manuell) - Interpret - Titel Call Teil_auslesen("1", 3, False) 'Interpret auslesen Call Teil_auslesen("2;2", 2, False) 'Titel auslesen Call Headertext("123") Worksheets(1).Activate Range("A1").Select End Sub
Sub Pfad_angeben() Dim Pfad As String Pfad = InputBox("Pfad angeben", , Worksheets(3).Range("A1").Value) Worksheets(3).Range("A1").Value = Pfad End Sub
Sub Pfad_einlesen() 'Name und Pfad einer Datei einlesen Dim varDatei As Variant 'Startverzeichnis festlegen: 'ChDrive "G:" 'erst das Laufwerk voreinstellen (bes. im Netzwerk oder bei mehreren Festplatten) 'ChDir "G:\My Shared Folder1" 'dann erst den Pfad vorbelegen varDatei = Application.GetOpenFilename _ ("MP3-Dateien,*.mp3," & _ "Alle Musik-Dateien,*.*", 1, "Eine Musikdatei anwählen") If varDatei = False Then MsgBox "Keine Datei angewählt." Exit Sub End If 'weitere Programmausführung hier ausserhalb von If...End If 'Debug.Print varDatei 'Debug.Print Dir(varDatei) Worksheets(3).Range("A1").Value = Left(varDatei, Len(varDatei) - Len(Dir(varDatei)) - 1) End Sub
Sub alles_loeschen() Worksheets(1).Range("A1:G1000").ClearContents Worksheets(2).Range("A2:G1000").ClearContents Worksheets(3).Range("A1").ClearContents End Sub
Sub Teil_loeschen() 'alles, außer Pfad löschen Worksheets(1).Range("A1:G1000").ClearContents Worksheets(2).Range("A2:G1000").ClearContents End Sub
Sub Extra() 'alles löschen, Pfad holen, Dateinamen auslesen Call Teil_loeschen Call Pfad_angeben Call Dateinamen_auslesen End Sub
Sub Extra2() 'alles löschen, Pfad holen, Dateinamen auslesen Call Teil_loeschen Call Pfad_einlesen Call Dateinamen_auslesen End Sub
Sub Dateinamen_kopieren() ' zum manuellen bearbeiten des kompletten Dateinamens Dim i As Byte i = 2 Do Until IsEmpty(Worksheets(2).Range("A" & i)) = True Worksheets(2).Range("A" & i).Copy Destination:=Worksheets(2).Range("B" & i) i = i + 1 Loop i = Empty Call Trennzeichen_zaehlen_1("B", "D") End Sub
Sub Dateinamen_kopieren_ohne_ETZ() ' zum manuellen bearbeiten des kompletten Dateinamens Dim i As Byte i = 2 With Worksheets(2) Do Until IsEmpty(Worksheets(2).Range("A" & i)) = True .Range("B" & i).Value = Left(.Range("A" & i), 3) & Right(.Range("A" & i), Len(.Range("A" & i)) - 5) i = i + 1 Loop End With i = Empty Call Trennzeichen_zaehlen_1("B", "D") End Sub
Sub ETZ_loeschen() ' zum manuellen bearbeiten des kompletten Dateinamens Dim i As Byte i = 2 With Worksheets(2) Do Until IsEmpty(Worksheets(2).Range("B" & i)) = True .Range("B" & i).Value = Left(.Range("B" & i), 3) & Right(.Range("B" & i), Len(.Range("B" & i)) - 5) i = i + 1 Loop End With i = Empty Call Trennzeichen_zaehlen_1("B", "D") End Sub
Sub Trennzeichen_zaehlen() Call Trennzeichen_zaehlen_1("B", "D") End Sub
Sub Trennzeichen_zaehlen_1(Lesespalte As String, Ausgabespalte As String) 'trennzeichen in den original Dateinamen lesen Dim TZ As String 'Trennzeichen Dim i, Anzahl_TZ As Byte Dim Text As String TZ = Worksheets(3).Range("B2").Value With Worksheets(2) i = 2 Do Until IsEmpty(.Range(Lesespalte & i)) = True Text = .Range(Lesespalte & i).Value Anzahl_TZ = Len(Text) - Len(Replace(Text, TZ, "")) .Range(Ausgabespalte & i).Value = Anzahl_TZ Anzahl_TZ = 0 i = i + 1 Loop End With i = Empty Text = Empty TZ = Empty End Sub
Sub ID_TAG_1_auslesen() Call ID_TAG_auslesen("TRCK", "TrackNr.") End Sub
Sub ID_TAG_2_auslesen() Call ID_TAG_auslesen("TPE1", "Interpret") End Sub
Sub ID_TAG_3_auslesen() Call ID_TAG_auslesen("TIT2", "Titel") End Sub
Sub ID_TAG_4_auslesen() Dim i As Byte ' Zähler Dim Spalte As Integer If ActiveSheet.Index <> 1 Then MsgBox ("falsches Arbeitsblatt ausgewählt") Exit Sub End If Spalte = ActiveCell.Cells.Column i = 2 With Worksheets(1) Do Until IsEmpty(.Range("A" & i)) = True .Cells(i, Spalte).Value = Right(Worksheets(2).Range("A" & i).Value, 3) i = i + 1 Loop End With Worksheets(1).Cells(1, Spalte).Value = "Endung" Worksheets(1).Range("A:D").Columns.AutoFit i = Empty End Sub