WMA Tags lesen Mit diesem Klassenmodul lassen sich alle WMA-Tags einer WMA-Musikdatei auslesen, falls vorhanden.
Autor:   Arne Elster	Bewertung:     [ Jetzt bewerten ]	Views:  12.720
actorics.de/rm_code	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 17 Bewertung insgesamt: gut Durchschnittliche Bewertung: 4.4 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

Dieser Tipp liest alle verfügbaren Tags aus WMA (Windows Media Audio) Dateien. Der Aufbau der Tags ist der gleiche wie bei ASF-Dateien, d.h. sie bestehen aus aneinandergereihten Objekten.

Das Klassenmodul sucht nur nach dem Objekt namens "(Extended) Content Description Object" und liest alle darin vorhandenen Tags aus. Anders als beim ID3v1 können hier beliebig viele Tags stehen.

Achtung: Sind ID3 Tags in der WMA Datei vorhanden, kann das Lesen fehlgeschlagen!

Erstellen Sie ein neues Projekt, fügen diesem ein neues Klassenmodul hinzu und benennen es clsReadWMATag.
Fügen Sie anschließend nachfolgenden Code in das Klassenmodul ein:

Option Explicit
 
' Speicheradressen kopieren
Private Declare Sub CopyMemory Lib "kernel32" _
  Alias "RtlMoveMemory" ( _
  pDst As Any, _
  pSrc As Any, _
  ByVal ByteLen As Long)
 
Private Type OBJ_HEADER
  Obj_ID(15)      As Byte     ' Objekt GUID
  Obj_Size        As Double   ' Objekt-Größe
  Obj_Headers     As Long     ' Header-Objekte
  rsvd(1)         As Byte     ' Reserviert
End Type
 
Private Type OBJ_DESCRIPTION
  Obj_ID(15)      As Byte     ' Objekt GUID
  Obj_Size        As Double   ' Objekt-Größe
  Title_Len       As Integer  ' Titel-Länge
  Author_Len      As Integer  ' Künstler-Länge
  Copyright_Len   As Integer  ' Copyright-Länge
  Description_Len As Integer  ' Beschreibungs-Länge
  Rating_Len      As Integer  ' Rating-Länge
End Type
 
Private Type OBJ_DESCRIPTION_EX
  Obj_ID(15)      As Byte     ' Objekt GUID
  Obj_Size        As Double   ' Objekt-Größe
  Descriptors     As Integer  ' Anzahl Beschreiber
End Type
 
' ASF Headerobjekt
Private Const GUID_ASF_HEADER As String = _
  "75B22630-668E-11CF-A6D9-00AA0062CE6C"
 
' Inhaltsbeschreibungsobjekt
Private Const GUID_CONTENT_DESCRIPTION_OBJECT As String = _
  "75B22633-668E-11CF-A6D9-00AA0062CE6C"
 
' Inhaltsbeschreibungsobjekt
Private Const GUID_CONTENT_DESCRIPTION_OBJECT_EX As String = _
  "D2D0A440-E307-11D2-97F0-00A0C95EA850"
 
Private strFile     As String   ' Dateiname
Private strTags()   As String   ' Tags
Private intTags     As Integer  ' Tagzähler

' Tag durch seinen Descriptor zurückgeben
Public Property Get TagByDescriptor(ByVal strDescriptor As String) As String
  Dim i As Integer
 
  For i = 0 To intTags - 1
    If LCase$(Split(strTags(i), Chr$(0))(0)) = LCase$(strDescriptor) Then
      TagByDescriptor = Split(strTags(i), Chr$(0))(1)
    End If
  Next i
End Property

' Tag Descriptors zurückgeben
Public Property Get TagDescriptors() As String()
  ' Zähler
  Dim i As Integer
  Dim j As Integer
 
  ' String-Array Puffer
  Dim strBuf() As String
 
  ' alle gefundenen Tags durchgehen
  For j = 0 To intTags - 1
    ' neuen Tag-Descriptor in String-Array einfügen
    ReDim Preserve strBuf(i) As String
    strBuf(i) = Split(strTags(j), Chr$(0))(0)
    i = i + 1
  Next j
 
  TagDescriptors = strBuf
End Property

' Anzahl gefundener Tags
Public Property Get TagCount() As Integer
  TagCount = intTags
End Property

' Dateiname
Public Property Get Filename() As String
  Filename = strFile
End Property
 
Public Property Let Filename(ByVal val As String)
  strFile = val
End Property

Public Function ReadWMATags() As Boolean
  On Error GoTo ErrHandler
 
  ' ---------------------------------------------------------------
  ' Headerobjekt
  Dim hdrobj As OBJ_HEADER
 
  ' WMA Beschreibungsobjekte
  Dim wmaobj As OBJ_DESCRIPTION_EX
  Dim descobj As OBJ_DESCRIPTION
 
  ' Dateihandle
  Dim FF As Integer
  FF = FreeFile
 
  ' GUID Puffer
  Dim GUID As String
 
  ' Zähler, nächste Leseadresse
  Dim i As Long
  Dim j As Long
  Dim NextAddr As Long
  ' ---------------------------------------------------------------
 
  ' ---------------------------------------------------------------
  ' Descriptorlänge, Descriptorname
  Dim intNameLen  As Integer
  Dim strDescName As String
 
  ' Descriptortyp
  Dim intDescType As Integer
 
  ' Wertlänge, Wertinhalt
  Dim intValLen As Integer
  Dim strValue As String
 
  ' Byte-Array
  Dim btBuf() As Byte
  ' ---------------------------------------------------------------
 
  If Filename = vbNullString Then Exit Function
 
  intTags = 0
 
  ' WMA Datei öffnen
  Open Filename For Binary As #FF
  ' Header Objekt lesen
  Get #FF, , hdrobj
 
  ' ASF Header?
  If Not ByteArrayToGUID(hdrobj.Obj_ID) = GUID_ASF_HEADER Then
    Close #FF
    Exit Function
  End If
 
  ' Header Objekte durcharbeiten
  For i = 0 To hdrobj.Obj_Headers - 1
    ' Beschreibungsobjekt lesen
    Get #FF, , descobj
 
    ' Nächste Leseadresse nach dem Objekt
    CopyMemory NextAddr, descobj.Obj_Size, 4
    NextAddr = Seek(FF) - Len(descobj) + NextAddr
 
    ' Objekt-GUID lesen
    GUID = ByteArrayToGUID(descobj.Obj_ID)
 
    ' Content Description Objekt?
    Select Case GUID
      Case GUID_CONTENT_DESCRIPTION_OBJECT
        ' Titel vorhanden?
        If Not descobj.Title_Len = 0 Then
          ReDim btBuf(descobj.Title_Len - 2) As Byte
          Get #FF, , btBuf          ' Titel lesen
          ReDim Preserve strTags(intTags) As String
          strTags(intTags) = "title" & Chr$(0) & UnicodeStr(btBuf)
          intTags = intTags + 1
        End If
 
        Seek #FF, Seek(FF) + 1    ' 1 Byte vorwärts
 
        ' Künstler vorhanden?
        If Not descobj.Author_Len = 0 Then
          ReDim btBuf(descobj.Author_Len - 2) As Byte
          Get #FF, , btBuf          ' Künstler lesen
          ReDim Preserve strTags(intTags) As String
          strTags(intTags) = "artist" & Chr$(0) & UnicodeStr(btBuf)
          intTags = intTags + 1
        End If
 
        Seek #FF, Seek(FF) + 1    ' 1 Byte vorwärts
 
      Case GUID_CONTENT_DESCRIPTION_OBJECT_EX
        ' An den Anfang des Objekts zurückkehren
        Seek #FF, Seek(FF) - Len(descobj)
 
        ' WMA Dateibeschreibung lesen
        Get #FF, , wmaobj
 
        ' alle Beschreibungen durcharbeiten
        For j = 0 To wmaobj.Descriptors - 1
          ' Descriptorlänge lesen
          Get #FF, , intNameLen
 
          ' Descriptornamenpuffer vorbereiten
          ReDim btBuf(intNameLen - 2) As Byte
 
          Get #FF, , btBuf        ' Descriptor lesen
          Seek #FF, Seek(FF) + 1  ' 1 Byte vorwärts
 
          ' Unicode beachten
          strDescName = UnicodeStr(btBuf)
 
          ' Descriptortyp lesen
          Get #FF, , intDescType
 
          ' Wertlänge lesen
          Get #FF, , intValLen
 
          ' Descriptorwertpuffer vorbereiten
          ReDim btBuf(intValLen - 2) As Byte
          Get #FF, , btBuf        ' Descriptorwert lesen
          Seek FF, Seek(FF) + 1   ' 1 Byte vorwärts
 
          ' Unicode beachten
          strValue = UnicodeStr(btBuf)
 
          ' String in strValue?
          If intDescType = 0 Then
            ReDim Preserve strTags(intTags) As String
            strTags(intTags) = strDescName & Chr$(0) & strValue
            intTags = intTags + 1
          End If
        Next j
    End Select
 
    ' Nächstes Objekt
    Seek #FF, NextAddr
    DoEvents
  Next i
 
  ' WMA Datei schließen
  Close #FF
  ReadWMATags = True
 
ErrHandler:
End Function

' Unicode Byte-Array in String kopieren
Private Function UnicodeStr(ByRef btBuf() As Byte) As String
  Dim i As Integer
  Dim lng As Long
 
  UnicodeStr = Space(UBound(btBuf) \ 2)
  For i = 0 To UBound(btBuf) Step 2
    CopyMemory ByVal StrPtr(UnicodeStr) + i, btBuf(i), 2
  Next i
End Function

Private Function ByteArrayToGUID(ByRef arr() As Byte) As String
  ' Nur 16 Elemente zugelassen
  If UBound(arr) > 15 Then Exit Function
 
  ' GUID aus Byte Array erstellen
  AppendString Format(Hex(arr(3)), "00")
  AppendString Format(Hex(arr(2)), "00")
  AppendString Format(Hex(arr(1)), "00")
  AppendString Format(Hex(arr(0)), "00")
  AppendString "-"
  AppendString Format(Hex(arr(5)), "00")
  AppendString Format(Hex(arr(4)), "00")
  AppendString "-"
  AppendString Format(Hex(arr(7)), "00")
  AppendString Format(Hex(arr(6)), "00")
  AppendString "-"
  AppendString Format(Hex(arr(8)), "00")
  AppendString Format(Hex(arr(9)), "00")
  AppendString "-"
  AppendString Format(Hex(arr(10)), "00")
  AppendString Format(Hex(arr(11)), "00")
  AppendString Format(Hex(arr(12)), "00")
  AppendString Format(Hex(arr(13)), "00")
  AppendString Format(Hex(arr(14)), "00")
  AppendString Format(Hex(arr(15)), "00")
 
  ' GUID zurückgeben
  ByteArrayToGUID = AppendString(ret:=True)
 
  ' Stringpuffer leeren
  AppendString ""
End Function

Private Function AppendString(Optional ByVal str As String, _
  Optional ByVal ret As Boolean) As String
 
  ' statischer Stringpuffer
  Static buffer As String
 
  ' String anhängen oder andere Operation?
  If Not str = vbNullString Then
    ' neuen Teil an String anhängen
    buffer = buffer & str
  Else
    ' Puffer zurückgeben?
    If Not ret Then
      ' nein, Puffer leeren
      buffer = vbNullString
    Else
      ' Puffer zurückgeben
      AppendString = buffer
    End If
  End If
End Function

Kleines Anwendungsbeispiel:
Folgender Testcode gibt alle gefundenen Tags der angegebenen WMA-Datei im Direktfenster aus:

Dim wmatag As New clsReadWMATag
Dim strTags() As String
Dim i As Integer
 
With wmatag
  .Filename = "C:\New Stories (Highway Blues).wma"
  If Not .ReadWMATags Then
    MsgBox "Konnte WMA Tags nicht lesen.", vbExclamation, "Error"
  Else
    Debug.Print .TagCount & " Tags gefunden" & vbCrLf
    strTags = .TagDescriptors
    For i = 0 To UBound(strTags)
      Debug.Print strTags(i) & ": " & .TagByDescriptor(strTags(i))
    Next i
  End If
End With