MP3-Tag lesen und schreiben

ActiveX-EXE, Klassenmodul, Instanzen einer Anwendung
Sub Form_Load()
Top = 0
Left = Screen.Width - Width
End Sub
'--------  Lesen des Tags  ----------------------
Sub File1_Click()
cmdKillOneTag.Visible = False
Call ReadMyFiles	Einzelnen MP3-Tag teilweise lesen und in TextBoxen schreiben.
If txtArtist <> "" Or txtTitle <> "" Or txtAlbum <> "" Or _
txtYear <> "" Or txtGenreCode <> "255" Or txtComment <> "" Then
cmdKillOneTag.Visible = True
End If
End Sub
Sub Dir1_Change()
File1.FileName = Dir1.Path
Call EraseTXTBoxes
cmdWriteTag.Visible = False
cmdKillOneTag.Visible = False
If File1.ListCount > 1 Then
cmdSerie.Visible = True
cmdKillTag.Visible = True
Else
cmdSerie.Visible = False
cmdKillTag.Visible = False
End If
End Sub
Sub Dir1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
File1.ListIndex = -1
Call Dir1_Change
End Sub
Sub File1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If File1.ListCount > 0 Then
File1.ToolTipText = "   Artist & Songname:  Use Drag & Drop !!!   "
End If
End Sub
Sub Drive1_Change()
Dim HelpStr$
HelpStr = Clipboard.GetText()
On Error GoTo Meldung          'Wenn Laufwerk nicht ansprechbar dann Fehlermeldung
If HelpStr <> "" Then
On Error GoTo 100
Dir1.Path = Clipboard.GetText()
Drive1.Drive = Clipboard.GetText()
On Error GoTo 0
Else
100:
Dir1.Path = Drive1.Drive        'Wählt ein Laufwerk in der DriveListBox aus
File1.FileName = Dir1.Path
End If
cmdWriteTag.Visible = False
cmdKillOneTag.Visible = False
Exit Sub                                    'Wenn Laufwerk ansprechbar, übergehe Fehlermeldung
Meldung:
Select Case MsgBox(Err.Description, 37, "Error No. " & Err.Number)
Case 2 'Programm-Exit
Resume Next
Case 4 'Befehl wiederholen
Resume
End Select
End Sub
'--------  Schreiben eines Tags  ----------------------
Sub cmdWriteTag_Click()
Call WriteMyMP3
Call ReadMyFiles
End Sub
'--------  Schreiben der Tags in Serie  -------------
Sub cmdSerie_Click()
Call WriteAllMP3s
End Sub
'--------  Löschen eines Tags  -------------
Sub cmdKillOneTag_Click()
Call KillOneTag
Call ReadMyFiles
End Sub
'--------  Löschen der Tags in Serie  -------------
Sub cmdKillTag_Click()
Call KillAllMP3Tags
End Sub
Sub txtAlbum_Change()
If File1.FileName = "" Then
cmdWriteTag.Visible = False
Else
cmdWriteTag.Visible = True
End If
End Sub
Sub txtAlbum_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then txtYear.SetFocus
End Sub
Sub txtAlbum_KeyPress(KeyAscii As Integer)
If File1.FileName = "" Then KeyAscii = 0
End Sub
Sub txtArtist_Change()
If File1.FileName = "" Then
cmdWriteTag.Visible = False
Else
cmdWriteTag.Visible = True
End If
End Sub
Sub txtArtist_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then txtTitle.SetFocus
End Sub
Sub txtArtist_KeyPress(KeyAscii As Integer)
If File1.FileName = "" Then KeyAscii = 0
End Sub
Sub txtArtist_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not File1.FileName = "" Then
Call Bindestrich_checken(Temp_Artist, Temp_Title)
txtArtist.Text = Temp_Artist
txtTitle.Text = Temp_Title
End If
End Sub
Sub txtComment_Change()
If File1.FileName = "" Then
cmdWriteTag.Visible = False
Else
cmdWriteTag.Visible = True
End If
End Sub
Sub txtComment_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then txtArtist.SetFocus
End Sub
Sub txtComment_KeyPress(KeyAscii As Integer)
If File1.FileName = "" Then KeyAscii = 0
End Sub
Sub txtGenreCode_Change()
If File1.FileName = "" Then
cmdWriteTag.Visible = False
Else
cmdWriteTag.Visible = True
End If
End Sub
Sub txtGenreCode_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then txtComment.SetFocus
End Sub
Sub txtGenreCode_KeyPress(KeyAscii As Integer)
If File1.FileName = "" Then KeyAscii = 0
Select Case Chr(KeyAscii)
Case "0" To "9"
Case Chr(vbKeyBack)
Case Else
KeyAscii = 0
End Select
End Sub
Sub txtTitle_Change()
If File1.FileName = "" Then
cmdWriteTag.Visible = False
Else
cmdWriteTag.Visible = True
End If
End Sub
Sub txtTitle_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then txtAlbum.SetFocus
End Sub
Sub txtTitle_KeyPress(KeyAscii As Integer)
If File1.FileName = "" Then KeyAscii = 0
End Sub
Sub txtTitle_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Not File1.FileName = "" Then
Call Bindestrich_checken(Temp_Artist, Temp_Title)
txtArtist.Text = Temp_Artist
txtTitle.Text = Temp_Title
End If
End Sub
Sub txtYear_Change()
If File1.FileName = "" Then
cmdWriteTag.Visible = False
Else
cmdWriteTag.Visible = True
End If
End Sub
Sub txtYear_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 13 Then txtGenreCode.SetFocus
End Sub
Sub txtYear_KeyPress(KeyAscii As Integer)
If File1.FileName = "" Then KeyAscii = 0
Select Case Chr(KeyAscii)
Case "0" To "9"
Case Chr(vbKeyBack)
Case Else
KeyAscii = 0
End Select
End Sub
Sub cmdEnd_Click()
Clipboard.Clear
Unload Me
End Sub
Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Clipboard.Clear
End Sub
Function Bindestrich_checken(Temp_Artist, Temp_Title)
On Error GoTo ende
Temp_Artist = "":  Temp_Title = "":  Temp_File = ""
Temp_File = Trim(Left(File1.FileName, Len(File1.FileName) - 4))
Temp_Artist = Trim(Left$(Temp_File, InStr(1, Temp_File, "-") - 1))
Temp_Title = Trim(Right$(Temp_File, Len(Temp_File) - InStr(1, Temp_File, "-")))
Exit Function
ende:
MsgBox "FileName has no hyphen     -      ", vbCritical, "Error"
Temp_Artist = "":  Temp_Title = "":  Temp_File = ""
End Function
Public CurrentTag As TagInfo, FileName$, Tempp$
Public Temp_Artist$, Temp_Title$, Temp_File$
Public f As frmMP3
Public Type TagInfo
tag As String * 3
songname As String * 30
artist As String * 30
album As String * 30
year As String * 4
comment As String * 30
genre As String * 1
End Type
Public Sub Main()
Dim OldTitle$
If App.PrevInstance Then
OldTitle = App.Title
App.Title = "SampleToDelete"
AppActivate OldTitle
End
Else
Set f = frmMP3
If App.StartMode = vbSModeStandalone Then
f.Show
End If
End If
End Sub
Function ReadMyFiles()	Einzelnen MP3-Tag lesen.
On Error Resume Next
f.cmdSerie.Visible = False
f.cmdKillTag.Visible = False
Call EraseTXTBoxes
If Right(f.Dir1.Path, 1) = "\" Then
FileName = f.Dir1.Path & f.File1.FileName
Else
FileName = f.Dir1.Path & "\" & f.File1.FileName
End If
Open FileName For Binary As #1
With CurrentTag
Get #1, FileLen(FileName) - 127, .tag
If Not .tag = "TAG" Then
f.txtArtist.Text = "N o  T a g !"
Close #1
Exit Function
End If
Get #1, , .songname
Get #1, , .artist
Get #1, , .album
Get #1, , .year
Get #1, , .comment
Get #1, , .genre
Close #1
f.txtArtist = RTrim(.artist)
f.txtTitle = RTrim(.songname)
f.txtAlbum = RTrim(.album)
f.txtYear = RTrim(.year)
f.txtComment = RTrim(.comment)
Tempp = RTrim(.genre)
f.txtGenreCode = Asc(Tempp)
' f.Combo1.ListIndex = CInt(txtGenreCode) - 1
End With
f.cmdWriteTag.Visible = False
Tempp = ""
End Function
Public Sub EraseTXTBoxes()
f.txtTitle.Text = vbNullString
f.txtArtist.Text = vbNullString
f.txtAlbum.Text = vbNullString
f.txtYear.Text = vbNullString
f.txtComment.Text = vbNullString
End Sub
Function WriteMyMP3()	Einen MP3-Tag schreiben.
Dim yearr%
If Right(f.Dir1.Path, 1) = "\" Then
FileName = f.Dir1.Path & f.File1.FileName
Else
FileName = f.Dir1.Path & "\" & f.File1.FileName
End If
If Not f.txtYear.Text = vbNullString Then yearr = f.txtYear.Text
If yearr = 0 Then
If f.txtYear.Text = vbNullString Then GoTo save1
MsgBox "Put the year between 1900 and 2100... and try again!  ", vbCritical, "MP3-Tag Save Error"
f.txtYear.SetFocus
f.txtYear.SelStart = 0
f.txtYear.SelLength = Len(f.txtYear.Text)
Exit Function
End If
save1:
If yearr < 1900 Or yearr > 2100 Then
If f.txtYear.Text = vbNullString Then GoTo save2
MsgBox "Put the year between 1900 and 2100... and try again!  ", vbCritical, "MP3-Tag Save Error"
f.txtYear.SetFocus
f.txtYear.SelStart = 0
f.txtYear.SelLength = Len(f.txtYear.Text)
Exit Function
End If
save2:
If f.txtTitle.Text = "" Or f.txtArtist.Text = "" Then
MsgBox "No entry for Artist or Songname...!   ", vbCritical, "MP3-Tag Save Error"
Else
If f.File1.FileName = "" Then Exit Function
With CurrentTag
.tag = "TAG"
.songname = f.txtTitle
.artist = f.txtArtist
.album = f.txtAlbum
.year = f.txtYear
.comment = f.txtComment
''  .genre = Chr(f.Combo1.ListIndex + 1)
.genre = Chr("255")                           'erzeugt keinen Eintrag
On Error GoTo Meldung
Open FileName For Binary Access Write As #1
Seek #1, FileLen(FileName) - 127
Put #1, , .tag
Put #1, , .songname
Put #1, , .artist
Put #1, , .album
Put #1, , .year
Put #1, , .comment
Put #1, , .genre
Close #1
End With
End If
On Error GoTo 0
f.txtArtist.SetFocus
f.cmdWriteTag.Visible = False
Exit Function
Meldung:
MsgBox "You can't save to an open file...!   ", vbCritical, "MP3-Tag Save Error"
Exit Function
End Function
Function WriteAllMP3s()	Alle MP3-Tags im Verzeichnis schreiben.
Dim i&, i2&, FileNam()
i = 0:  i2 = 0
Select Case MsgBox("Program will take 'Artist' and 'Songname' from Filename!     " & vbCrLf _
& "Please close all Files in WinAmp and De-Select Files in Explorer...   " _
& vbCrLf & vbCrLf & "Write all Files in this Directory?    ", _
vbQuestion + vbYesNo + vbDefaultButton2, "Write All Files?")
Case vbYes
For i = 0 To f.File1.ListCount - 1
10:
ReDim Preserve FileNam(1 To i + 1)
FileNam(i + 1) = f.File1.List(i)
If Right(f.Dir1.Path, 1) = "\" Then
FileNam(i + 1) = f.Dir1.Path & f.File1.List(i)
Else
FileNam(i + 1) = f.Dir1.Path & "\" & f.File1.List(i)
End If
If FileNam(i + 1) = "" Then Exit Function
On Error GoTo error_counter
With CurrentTag
Temp_Artist = "":  Temp_Title = "":  Temp_File = ""
Temp_File = Trim(Left(f.File1.List(i), Len(f.File1.List(i)) - 4))
Temp_Artist = Left$(Temp_File, InStr(1, Temp_File, "-") - 1)
Temp_Title = Right$(Temp_File, (Len(f.File1.List(i)) - 4) - (InStr(1, Temp_File, "-")))
.tag = "TAG"
.songname = LTrim(Temp_Title)
.artist = RTrim(Temp_Artist)
.album = vbNullString
.year = vbNullString
.comment = vbNullString
.genre = Chr("255")   'erzeugt keinen Eintrag
Open FileNam(i + 1) For Binary Access Write As #1
Seek #1, FileLen(FileNam(i + 1)) - 127
Put #1, , .tag
Put #1, , .songname
Put #1, , .artist
Put #1, , .album
Put #1, , .year
Put #1, , .comment
Put #1, , .genre
Close #1
On Error GoTo 0
End With
Next i
End Select
If i2 = 0 And i > 0 Then
MsgBox i & " MP3-Tags Saved!       ", vbInformation, "MP3-Tags Saved"
ElseIf i2 > 0 Then
MsgBox "You can't save " & i2 & " file(s)...!   ", vbCritical, "MP3-Tag Save Error"
End If
f.txtArtist.SetFocus
f.cmdWriteTag.Visible = False
f.cmdSerie.Visible = False
f.cmdKillTag.Visible = False
Exit Function
error_counter:
i2 = i2 + 1
i = i + 1
GoTo 10
End Function
Function KillOneTag()	Einen MP3-Tag löschen.
If Right(f.Dir1.Path, 1) = "\" Then
FileName = f.Dir1.Path & f.File1.FileName
Else
FileName = f.Dir1.Path & "\" & f.File1.FileName
End If
If f.File1.FileName = "" Then Exit Function
With CurrentTag
.tag = vbNullString
.songname = vbNullString
.artist = vbNullString
.album = vbNullString
.year = vbNullString
.comment = vbNullString
'  .genre = Chr(f.Combo1.ListIndex + 1)
.genre = Chr("255")   'erzeugt keinen Eintrag
On Error GoTo Meldung
Open FileName For Binary Access Write As #1
Seek #1, FileLen(FileName) - 127
Put #1, , .tag
Put #1, , .songname
Put #1, , .artist
Put #1, , .album
Put #1, , .year
Put #1, , .comment
Put #1, , .genre
Close #1
End With
On Error GoTo 0
f.txtArtist.SetFocus
f.cmdWriteTag.Visible = False
f.cmdKillOneTag.Visible = False
Exit Function
Meldung:
MsgBox "You can't save to an open file...!   ", vbCritical, "MP3-Tag Save Error"
Exit Function
End Function
Function KillAllMP3Tags()	Alle MP3-Tags im Verzeichnis löschen.
Dim i&, i2&, FileNam()
i = 0:  i2 = 0
Select Case MsgBox("Program will  k i l l  all Tags from File!     " & vbCrLf _
& "Please close all Files in WinAmp and De-Select Files in Explorer...   " _
& vbCrLf & vbCrLf & "Kill all Tags in this Directory?    ", _
vbQuestion + vbYesNo + vbDefaultButton2, "Kill All Tags?")
Case vbYes
For i = 0 To f.File1.ListCount - 1
10:
ReDim Preserve FileNam(1 To i + 1)
FileNam(i + 1) = f.File1.List(i)
If Right(f.Dir1.Path, 1) = "\" Then
FileNam(i + 1) = f.Dir1.Path & f.File1.List(i)
Else
FileNam(i + 1) = f.Dir1.Path & "\" & f.File1.List(i)
End If
If FileNam(i + 1) = "" Then Exit Function
On Error GoTo error_counter
With CurrentTag
.tag = vbNullString
.songname = vbNullString
.artist = vbNullString
.album = vbNullString
.year = vbNullString
.comment = vbNullString
.genre = Chr("255")                         'erzeugt keinen Eintrag
Open FileNam(i + 1) For Binary Access Write As #1
Seek #1, FileLen(FileNam(i + 1)) - 127
Put #1, , .tag
Put #1, , .songname
Put #1, , .artist
Put #1, , .album
Put #1, , .year
Put #1, , .comment
Put #1, , .genre
Close #1
On Error GoTo 0
End With
Next i
End Select
If i2 = 0 And i > 0 Then
MsgBox i & " MP3-Tags Killed!       ", vbInformation, "MP3-Tags Killed"
ElseIf i2 > 0 Then
MsgBox "You can't save " & i2 & " file(s)...!   ", vbCritical, "MP3-Tag Save Error"
End If
f.txtArtist.SetFocus
f.cmdWriteTag.Visible = False
f.cmdSerie.Visible = False
f.cmdKillTag.Visible = False
Exit Function
error_counter:
i2 = i2 + 1
i = i + 1
GoTo 10
End Function
Klassenmodul:
Private Sub Class_Initialize()
If Forms.Count = 0 Then
Load frmMP3
End If
With frmMP3
If .WindowState = vbMinimized Then
.WindowState = vbNormal
End If
.Show
End With
End Sub
Public Function MP3Start(Params As String) As Variant
On Error GoTo weiter
frmMP3.Dir1.Path = Clipboard.GetText()
frmMP3.Drive1.Drive = Clipboard.GetText()
Exit Function
weiter:
On Error Resume Next
frmMP3.Dir1.Path = "C:\"
frmMP3.Drive1.Drive = "C:\"
End Function
Starter-EXE:
Public Sub Main()
Dim Instanz As ReadWriteMP3.MP3Instanz
Set Instanz = New ReadWriteMP3.MP3Instanz
With New ReadWriteMP3.MP3Instanz
.MP3Start Command$
End With
End Sub
Instanzen eines Formulars
Die Eigenschaft PrevInstance des App-Objekts teilt mit, ob bereits weitere Instanzen einer Anwendung laufen. Wenn man nun bei
einem erneuten Start einer Anwendung eine solche vorhergehende Instanz lediglich aktivieren möchten, anstatt die Anwendung
zum zweiten Mal auszuführen, bedarf es einiger Kunstgriffe. Visual Basic hält dazu keine eigenen Bordmittel bereit.
Eine bekannte Möglichkeit ist, über eine Reihe von API-Funktionen ein Fenster (Form) der vorhergehenden Instanz ausfindig zu machen
und zu aktivieren, und es gegebenenfalls wiederherzustellen, falls es minimiert sein sollte. In der Regel funktioniert dies auch ganz gut.
Allzu sicher ist das Verfahren jedoch nicht, da zwischen der bereits laufenden Instanz und der sich um die Reaktivierung derselben
bemühenden neuen Instanz keinerlei direkte Beziehung besteht. Zum einen kann man unabsichtlich eine völlig andere Anwendung
reaktivieren, falls zufällig verschiedene Namensübereinstimmungen zur eigenen Anwendung bestehen sollten.
Zum anderen kann die neue Instanz nichts über den Zustand der laufenden Anwendung wissen. Sie kann vielleicht vergeblich nach dem zu
reaktivierenden Form suchen, während dieses gar nicht geladen ist. Oder dieses Form ist zufällig gesperrt, weil der Anwender gerade ein
anderes Form der Anwendung modal geöffnet hat. Je nach Komplexität Ihrer Anwendung können weitere Unwägbarkeiten hinzukommen,
über die sich die neu startende Instanz nur mit (für VB-Verhältnisse) recht hohem Aufwand über API-Mechanismen informieren könnte.
Auch ist eine gezielte Kommunikation zwischen den beiden Instanzen, etwa Übergabe der Kommandozeilen-Parameter der neuen
Instanz an die alte und dergleichen, nicht so einfach zu erreichen.