Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0686: Windows-Media-Tags lesen

VB 5/6-Tipp 0686: Windows-Media-Tags lesen

 von rm

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CallWindowProcA, RtlMoveMemory (CpyMem), RtlFillMemory, WMCreateSyncReader, RtlZeroMemory (ZeroMemory)

Download: Download des Beispielprojektes [6,05 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei WMHeader.vbp -------------
'--- Anfang Formular "frmWMHeader" alias frmWMHeader.frm  ---

Option Explicit

Private WithEvents objCmdRead   As CommandButton
Private objLstTags              As ListBox
Private objTxtFile              As TextBox
Private cWMTags                 As clsWMTags

Private Sub Form_Load()
    Set cWMTags = New clsWMTags

    Me.ScaleMode = vbPixels
    Me.Caption = "Windows Media Tags"
    Me.Height = 4500
    Me.Width = 7000

    Set objCmdRead = Controls.Add("VB.CommandButton", "cmdRead")
    With objCmdRead
        .Caption = "Tags lesen"
        .Width = 80
        .Height = 23
        .Left = Me.ScaleWidth - .Width * 1.1
        .Top = .Height / 2
        .Visible = True
    End With

    Set objTxtFile = Controls.Add("VB.TextBox", "txtFile")
    With objTxtFile
        .Text = "C:\MP3s\track.wma"
        .Left = 10
        .Height = objCmdRead.Height
        .Width = objCmdRead.Left - .Left * 2
        .Top = objCmdRead.Top
        .Visible = True
    End With

    Set objLstTags = Controls.Add("VB.ListBox", "lstTags")
    With objLstTags
        .Left = objTxtFile.Left
        .Top = objTxtFile.Top + objTxtFile.Height + 10
        .Width = Me.ScaleWidth - .Left * 2
        .Height = Me.ScaleHeight - .Top
        .Visible = True
    End With
End Sub

Private Sub objCmdRead_Click()
    Dim i   As Long

    If Not cWMTags.ReadTags(objTxtFile.Text) Then
        MsgBox "Konnte Tags nicht lesen.", vbExclamation
        Exit Sub
    End If
    With cWMTags
        For i = 0 To .TagCount - 1
            objLstTags.AddItem .TagName(i) & ": " & .TagValue(i)
        Next
    End With
End Sub

'---- Ende Formular "frmWMHeader" alias frmWMHeader.frm  ----
'------ Anfang Klasse "clsWMTags" alias clsWMTags.cls  ------

Option Explicit

 ' /////////////////////////////////
    ' clsWMTags
    '
    ' liest Tags aus allen Arten
    ' von Windows Media Formaten
    '
    ' Referenz: Windows Media Format SDK 9
    ' http://www.microsoft.com/windows/windowsmedia/mp10/sdk.aspx
    '
    ' [rm]
 ' /////////////////////////////////
 
 
' ----==== wmvcore -Enums und -Konstanten ====----

Private Enum WMT_RIGHTS
    WMT_RIGHT_PLAYBACK = &H1
    WMT_RIGHT_COPY_TO_NON_SDMI_DEVICE = &H2
    WMT_RIGHT_COPY_TO_CD = &H8
    WMT_RIGHT_COPY_TO_SDMI_DEVICE = &H10
    WMT_RIGHT_ONE_TIME = &H20
    WMT_RIGHT_SAVE_STREAM_PROTECTED = &H40
    WMT_RIGHT_COPY = &H80
    WMT_RIGHT_COLLABORATIVE_PLAY = &H100
    WMT_RIGHT_SDMI_TRIGGER = &H10000
    WMT_RIGHT_SDMI_NOMORECOPIES = &H20000
End Enum

Public Enum WMT_ATTR_DATATYPE
    WMT_TYPE_DWORD = 0
    WMT_TYPE_STRING = 1
    WMT_TYPE_BINARY = 2
    WMT_TYPE_BOOL = 3
    WMT_TYPE_QWORD = 4
    WMT_TYPE_WORD = 5
    WMT_TYPE_GUID = 6
End Enum

' Zum Anfordern einer IWMHeaderInfo3-Struktur wird ein _
                                 GUID-Schlüssel benötigt
Private Const IID_IWMHeaderInfo3    As String _
    = "{15CC68E3-27CC-4ecd-B222-3F5D02D80BD5}"
    
Private Const IID_IUnknown          As String _
    = "{00000000-0000-0000-C000-000000000046}"

Private Const IID_IWMSyncReader     As String _
    = "{9397F121-7705-4dc9-B049-98B698188414}"
    

' ----==== wmvcore - Typen ====----

Private Type IUnknown
    QueryInterface              As Long
    AddRef                      As Long
    Release                     As Long
End Type

' repräsentiert die Funktionspointer eines entsprechenden _
               Interfaces (seine VTable) in der wmvcore.dll
Private Type IWMSyncReader
    IUnk                        As IUnknown
    Open                        As Long
    Close                       As Long
    SetRange                    As Long
    SetRangeByFrame             As Long
    GetNextSample               As Long
    SetStreamsSelected          As Long
    GetStreamSelected           As Long
    SetReadStreamSamples        As Long
    GetReadStreamSamples        As Long
    GetOutputSetting            As Long
    SetOutputSetting            As Long
    GetOutputCount              As Long
    GetOutputProps              As Long
    SetOutputProps              As Long
    GetOutputFormatCount        As Long
    GetOutputFormat             As Long
    GetOutputNumberForStream    As Long
    GetStreamNumberForOutput    As Long
    GetMaxOutputSampleSize      As Long
    GetMaxStreamSampleSize      As Long
    OpenStream                  As Long
End Type


' repräsentiert die Funktionspointer eines entsprechenden _
               Interfaces (seine VTable) in der wmvcore.dll
Private Type IWMHeaderInfo3
    IUnk                        As IUnknown
    GetAttributeCount           As Long
    GetAttributeByIndex         As Long
    GetAttributeByName          As Long
    SetAttribute                As Long
    GetMarkerCount              As Long
    GetMarker                   As Long
    AddMarker                   As Long
    RemoveMarker                As Long
    GetScriptCount              As Long
    GetScript                   As Long
    AddScript                   As Long
    RemoveScript                As Long
    GetCodecInfoCount           As Long
    GetCodecInfo                As Long
    GetAttributeCountEx         As Long
    GetAttributeIndices         As Long
    GetAttributeByIndexEx       As Long
    ModifyAttribute             As Long
    AddAttribute                As Long
    DeleteAttribute             As Long
    AddCodecInfo                As Long
End Type
   
' ----==== sonstige Typen ====----

Private Type TagInfo
    strName     As String
    udeType     As WMT_ATTR_DATATYPE
    varVal      As Variant
End Type

Private Type GUID
    Data1                       As Long
    Data2                       As Integer
    Data3                       As Integer
    Data4(7)                    As Byte
End Type
   
' ----==== user32 API Funktions-Deklarationen ====----

Private Declare Function CallWindowProcA Lib "user32" ( _
    ByVal ADR As Long, _
    ByVal p1 As Long, _
    ByVal p2 As Long, _
    ByVal p3 As Long, _
    ByVal p4 As Long _
) As Long

' ----==== wmvcore API Funktions-Deklarationen ====----

Private Declare Function WMCreateSyncReader Lib "wmvcore" ( _
    ByVal pUnkCert As Long, _
    ByVal dwRights As Long, _
    ByVal ppSyncReader As Long _
) As Long

' ----==== kernel32 API Funktions-Deklarationen ====----

Private Declare Sub CpyMem Lib "kernel32" _
Alias "RtlMoveMemory" ( _
    pDst As Any, _
    pSrc As Any, _
    ByVal dwLen As Long _
)

Private Declare Sub ZeroMemory Lib "kernel32" _
Alias "RtlZeroMemory" ( _
    pDst As Any, _
    ByVal dwLen As Long _
)

Private Declare Sub RtlFillMemory Lib "kernel32" ( _
    pDst As Any, _
    ByVal dlen As Long, _
    ByVal Fill As Byte _
)


' ----==== Private Variablen ====----

Private IReader                 As IWMSyncReader
Private oReader                 As Long
Private pReaderVTbl             As Long

Private IHeader                 As IWMHeaderInfo3
Private oHeader                 As Long
Private pHeaderVTbl             As Long

Private udtTags()               As TagInfo
Private lngTagCount             As Long

' ----==== Public Properties ====----

Public Property Get TagCount() As Long
    TagCount = lngTagCount
End Property

Public Property Get TagName( _
    ByVal index As Long _
) As String

    TagName = udtTags(index).strName
End Property

Public Property Get TagType( _
    ByVal index As Long _
) As WMT_ATTR_DATATYPE

    TagType = udtTags(index).udeType
End Property

Public Property Get TagValue( _
    ByVal index As Long _
) As Variant

    TagValue = udtTags(index).varVal
End Property


' ----==== Public Funktionen ====----

Public Function ReadTags( _
    ByVal strFile As String _
) As Boolean

 '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    '   Attribute: Anzahl und aktueller Index
    Dim cAttrs      As Long, attIndex   As Integer
    '   Typ des Attributs
    Dim attType     As WMT_ATTR_DATATYPE
  '
    '   Attributsname          Attributinhalt
    Dim pwszName    As String, pbValue() As Byte
    '   Namenslänge             Länge des Inhalts
    Dim cchName     As Integer, cbValue  As Long
  '
    '   Attributzwischenspeicher
    Dim udtTag      As TagInfo
    ' +
    ' +
    '   IWMHeaderInfo3 IID
    Dim iid_hdr     As GUID
    '+
    '+
    '   HRESULT
    Dim lngRet      As Long
 '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\

    lngTagCount = 0

    If strFile = "" Then Exit Function
    If oReader = 0 Then Exit Function

    ' Datei öffnen
    lngRet = CallPointer(IReader.Open, oReader, StrPtr(strFile))
    If lngRet <> 0 Then Exit Function

    ' IWMHeaderInfo3 aus IWMSyncReader holen
    iid_hdr = Str2GUID(IID_IWMHeaderInfo3)
    lngRet = CallPointer(IReader.IUnk.QueryInterface, _
                         oReader, _
                         VarPtr(iid_hdr), _
                         VarPtr(oHeader))
    If lngRet <> 0 Then Exit Function

    ' IWMHeaderInfo3`s VTable
    CpyMem pHeaderVTbl, ByVal oHeader, 4
    CpyMem IHeader, ByVal pHeaderVTbl, Len(IHeader)

    ' Anzahl an Attributen erfragen
    lngRet = CallPointer(IHeader.GetAttributeCountEx, _
                         oHeader, _
                         &HFFFF&, _
                         VarPtr(cAttrs))

    If lngRet <> 0 Then
        lngRet = CallPointer(IHeader.IUnk.Release, oHeader)
        oHeader = 0
        Exit Function
    End If

    For attIndex = 0 To cAttrs - 1

        ' Länge des Attributsnamens und -inhalts holen
        lngRet = CallPointer(IHeader.GetAttributeByIndexEx, _
                             oHeader, _
                             &HFFFF&, _
                             attIndex, _
                             0, _
                             VarPtr(cchName), _
                             0, 0, 0, _
                             VarPtr(cbValue))

        If lngRet <> 0 Then Goto NextAttribute

        ' Platz schaffen für Attributsdaten
        pwszName = Space(cchName)
        ReDim pbValue(cbValue - 1) As Byte

        ' Attribut vollständig auslesen
        lngRet = CallPointer(IHeader.GetAttributeByIndexEx, _
                             oHeader, _
                             &HFFFF&, _
                             attIndex, _
                             StrPtr(pwszName), _
                             VarPtr(cchName), _
                             VarPtr(attType), _
                             0, _
                             VarPtr(pbValue(0)), _
                             VarPtr(cbValue))

        If lngRet <> 0 Then Goto NextAttribute

        pwszName = TrimEx(pwszName)
        udtTag.strName = pwszName
        udtTag.udeType = attType

        Select Case attType

            ' Integer
            Case WMT_TYPE_WORD:
                Dim intVal  As Integer
                CpyMem intVal, pbValue(0), 2
                udtTag.varVal = intVal

            ' Long
            Case WMT_TYPE_DWORD:
                Dim lngVal  As Long
                CpyMem lngVal, pbValue(0), 4
                udtTag.varVal = lngVal

            ' nicht wirklich Currency,
            ' aber VB hat keinen kompatibleren Typ
            ' zu QWORD
            Case WMT_TYPE_QWORD:
                Dim curVal  As Currency
                CpyMem curVal, pbValue(0), 8
                udtTag.varVal = curVal

            ' String
            Case WMT_TYPE_STRING:
                udtTag.varVal = CStr(pbValue)

            ' Boolean
            Case WMT_TYPE_BOOL:
                CpyMem lngVal, pbValue(0), cbValue
                udtTag.varVal = CBool(lngVal)

            ' GUID
            Case WMT_TYPE_GUID:
                Dim g   As GUID
                CpyMem g, pbValue(0), Len(g)
                udtTag.varVal = GUID2Str(g)

            ' WMT_TYPE_BINARY wäre auch noch
            ' möglich, hielt ich allerdings
            ' für nicht notwendig

        End Select

        ReDim Preserve udtTags(lngTagCount) As TagInfo
        udtTags(lngTagCount) = udtTag
        lngTagCount = lngTagCount + 1

NextAttribute:
    Next

    ' IWMHeaderInfo3 zerstören
    lngRet = CallPointer(IHeader.IUnk.Release, oHeader)
    oHeader = 0

    lngRet = CallPointer(IReader.Close, oReader)

    ReadTags = True
End Function


' ----==== Private Ereignisverarbeitung ====----

Private Sub Class_Initialize()
    Dim lngRet  As Long

    ' IWMSyncReader Objekt erstellen
    lngRet = WMCreateSyncReader(0, _
                                WMT_RIGHT_PLAYBACK, _
                                VarPtr(oReader))

    If lngRet <> 0 Then
        oReader = 0
        Exit Sub
    End If

    ' VTable von IWMSyncReader Objekt
    CpyMem pReaderVTbl, ByVal oReader, 4
    CpyMem IReader, ByVal pReaderVTbl, Len(IReader)
End Sub

Private Sub Class_Terminate()
    Dim lngRet  As Long

    ' IWMSyncRader Objekt zerstören
    If oReader <> 0 Then
        lngRet = CallPointer(IReader.IUnk.Release, oReader)
    End If
End Sub


' ----==== Private Prozeduren ====----

' eine Funktion per Funktions-Adresse (fnc) aufrufen
Private Function CallPointer( _
    ByVal fnc As Long, _
    ParamArray Params() _
) As Long

    Dim btASM(&HEC00& - 1)  As Byte
    Dim pASM                As Long
    Dim i                   As Integer

    pASM = VarPtr(btASM(0))

    ' Code Array mit INT 3s füllen (Debugger)
    RtlFillMemory ByVal pASM, &HEC00&, &HCC

    AddByte pASM, &H58                  ' POP EAX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H59                  ' POP ECX
    AddByte pASM, &H50                  ' PUSH EAX

    If UBound(Params) = 0 Then
        If IsArray(Params(0)) Then
            For i = UBound(Params(0)) To 0 Step -1
                AddPush pASM, CLng(Params(0)(i))    ' PUSH dword
            Next
        Else
            For i = UBound(Params) To 0 Step -1
                AddPush pASM, CLng(Params(i))       ' PUSH dword
            Next
        End If
    Else
        For i = UBound(Params) To 0 Step -1
            AddPush pASM, CLng(Params(i))           ' PUSH dword
        Next
    End If

    AddCall pASM, fnc                   ' CALL rel addr
    AddByte pASM, &HC3                  ' RET

    ' Assembler ausführen
    CallPointer = CallWindowProcA(VarPtr(btASM(0)), _
                                  0, 0, 0, 0)
End Function

' =============================================
' Kleine Assembler Helfer
' =============================================

Private Sub AddPush(pASM As Long, lng As Long)
    AddByte pASM, &H68
    AddLong pASM, lng
End Sub

Private Sub AddCall(pASM As Long, addr As Long)
    AddByte pASM, &HE8
    AddLong pASM, addr - pASM - 4
End Sub

Private Sub AddLong(pASM As Long, lng As Long)
    CpyMem ByVal pASM, lng, 4
    pASM = pASM + 4
End Sub

Private Sub AddByte(pASM As Long, Bt As Byte)
    CpyMem ByVal pASM, Bt, 1
    pASM = pASM + 1
End Sub

' =============================================
' Andere Helfer
' =============================================

' GUID Struktur nach String
Private Function GUID2Str( _
    g As GUID _
) As String

    Dim nTemp   As String

    nTemp = "{"
    nTemp = nTemp & FmtStrLen(Hex$(g.Data1), 8) & "-"
    nTemp = nTemp & FmtStrLen(Hex$(g.Data2), 4) & "-"
    nTemp = nTemp & FmtStrLen(Hex$(g.Data3), 4) & "-"
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(0)), 2)
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(1)), 2) & "-"
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(2)), 2)
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(3)), 2)
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(4)), 2)
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(5)), 2)
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(6)), 2)
    nTemp = nTemp & FmtStrLen(Hex$(g.Data4(7)), 2) & "}"

    GUID2Str = nTemp
End Function

' String nach GUID Struktur
Private Function Str2GUID( _
    strGUID As String _
) As GUID

    Dim g           As GUID
    Dim strParts()  As String

    strParts = Split(Mid$(strGUID, 2, Len(strGUID) - 2), "-")

    g.Data1 = Val("&H" & strParts(0))
    g.Data2 = Val("&H" & strParts(1))
    g.Data3 = Val("&H" & strParts(2))
    g.Data4(0) = Val("&H" & Mid$(strParts(3), 1, 2))
    g.Data4(1) = Val("&H" & Mid$(strParts(3), 3, 2))
    g.Data4(2) = Val("&H" & Mid$(strParts(4), 1, 2))
    g.Data4(3) = Val("&H" & Mid$(strParts(4), 3, 2))
    g.Data4(4) = Val("&H" & Mid$(strParts(4), 5, 2))
    g.Data4(5) = Val("&H" & Mid$(strParts(4), 7, 2))
    g.Data4(6) = Val("&H" & Mid$(strParts(4), 9, 2))
    g.Data4(7) = Val("&H" & Mid$(strParts(4), 11, 2))

    Str2GUID = g
End Function

' Chr(0)s entfernen und String trimmen
Private Function TrimEx(s As String) As String
    TrimEx = Trim$(Left$(s, InStrRev(s, Chr$(0)) - 1))
End Function


' Nullen an einen String anfügen
Private Function FmtStrLen( _
    ByVal B As String, _
    Length As Integer _
) As String

    B = String(Length - Len(B), "0") & B
    FmtStrLen = B
End Function

'------- Ende Klasse "clsWMTags" alias clsWMTags.cls  -------
'-------------- Ende Projektdatei WMHeader.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 1 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.