aktuellen Song aus dem WMP auslesen?

[easteregg]

Heyho

kann mir jemand mal einen tipp geben wie ich das hinbekommen könnte?
mit winamp hab ich es ja aus dem application titel nehmen können, weil der name da immer drin steht!

aber beim aktuellen WMP (Bei mir die 9 ) klappt das nicht, weil die nicht im fenstertitel angezeigt wird.
hätte jemand ne idee wie ich das dennoch schaffe?

[easteregg]

+ah - s - push it!+

keine ne idee für mich?

[easteregg]

also ich hab jetzt mittlerweile mal den classname rausgefunden (WMPlayerApp) und bissl rumgesucht, aber nur ansätze gefunden wie ich den player steuern kann, aber das ist ja nicht das was ich will.

ich möchte ja den titel auslesen, das muss doch irgendwie möglich sein!
hat denn keiner ne idee für mich?

[Klaus01]

Hallo Richi,

hast Du schonmal hier geschaut -> http://www.experts-exchange.com/Prog..._21347965.html

Grüße
Klaus

[easteregg]

joa, das hab ich schon gefunden, aber nuja.

Zitat:

You Need to Subscribe to View This Solution

die wollen geld dafür (

[cyberblast]

Habe genau das selbe Problem!
Ich möchte ebenfalls den aktuell gespielten Song aus einer bereits laufenden WMP Instanz auslesen...

Habe bisher mal folgendes zusammengeschnippselt als machbarkeitsstudie, gibt zwar keine Fehler aber die laufende Instanz macht keinen mucks

Kann jemand damit was anfangen und zum laufen bringen?

(Der code versucht erstmal die play-funktion zu aktivieren)

Delphi-Quellcode:

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComObj, ActiveX, WMPLib_TLB;

type
  TfrmMain = class(TForm)
    init2: TButton;
    procedure init2Click(Sender: TObject);
  private
    { Private-Deklarationen }
  public
    { Public-Deklarationen }
  end;

var
  frmMain: TfrmMain;

implementation

var
   WMP : IWMPPlayer4Disp;
   RES : IWMPPlayer4;

const
  IID_IClassFactory: TGUID = (
    D1:$00000001;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));

{$R *.dfm}


procedure TfrmMain.init2Click(Sender: TObject);
var hr : HRESULT;
    mpclassid : TGUID; //CLSID
    cf : IClassFactory;
    iid : TIID;
begin
     hr := CLSIDFromProgID('WMPlayer.OCX.7', mpclassid);
     if Failed(hr) then begin
        showmessage('Failed getting classid for Windows Media Player');
        Exit;
     end;

     hr := CoGetClassObject(mpclassid, CLSCTX_ALL, nil, IID_IClassFactory, cf);
     if Failed(hr) then begin
        showmessage('Fehler');
        Exit;
     end;

     hr := cf.CreateInstance(nil, IID_IWMPControls, CTL);
     if Failed(hr) then begin
        showmessage('Failed Instantiate Controls');
        Exit;
     end;

     hr := CoCreateInstance(mpclassid, nil, CLSCTX_INPROC_SERVER, IID_IWMPPlayer4, res);
     if Failed(hr) then begin
        showmessage('Failed instantiating Windows Media Player control!');
        Exit;
     end;
     
     WMP := RES as IWMPPlayer4Disp;
     CTL.play; //nichts tut sich
 
     //Das würde funktionieren: (mit laufender Instanz)   
     //WMP.openPlayer('C:\Test.mp3');
end;


initialization
    CoInitialize(nil);

end.

Grüsse Martin

[BassFan]

Du beötigst dafür eine Stream-Reader Classe oder ähnlich.

Ich hätte dafür etwas 'WMA,MP3' mit den benötigten GUIDS und das auslesen der Tags allerdings in Vb!
Wenn du in der lage bist das zu übersetzen kann ich es hier als schnipsel einfügen.

grüße

[KingIR]

Jo poste mal bitte, das wäre interessant

[BassFan]

Zitat von KingIR:

Jo poste mal bitte, das wäre interessant

Hier die StreamWMA Classe:

Code:

Option Explicit

Implements ISoundStream
Implements ISoundInfo


Private Const Extensions As String = "wma;mp3"
Private Const Description As String = "Windows Media Audio"


Private Enum HRESULT
    S_OK = 0
End Enum

Private Enum WMT_VERSION
    WMT_VER_4_0 = &H40000
    WMT_VER_7_0 = &H70000
    WMT_VER_8_0 = &H80000
    WMT_VER_9_0 = &H90000
End Enum

Private 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

Private Enum WMT_ERRORS
    NS_E_NO_MORE_SAMPLES = &HC00D0BCF
End Enum

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

Private Type MMWAVEFORMATEX
    wFormatTag                  As Integer
    nChannels                   As Integer
    nSamplesPerSec              As Long
    nAvgBytesPerSec             As Long
    nBlockAlign                 As Integer
    wBitsPerSample              As Integer
    cbSize                      As Integer
End Type

Private Type QWORD
    lo                          As Long
    hi                          As Long
End Type

Private Type GUID
    Data1                       As Long
    Data2                       As Integer
    Data3                       As Integer
    Data4(7)                    As Byte
End Type

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

Private Type IWMWriter
    IUnk                        As IUnknown
    SetProfileByID              As Long
    SetProfile                  As Long
    SetOutputFilename           As Long
    GetInputCount               As Long
    GetInputProps               As Long
    SetInputProps               As Long
    GetInputFormatCount         As Long
    GetInputFormat              As Long
    BeginWriting                As Long
    EndWriting                  As Long
    AllocateSample              As Long
    WriteSample                 As Long
    Flush                       As Long
End Type

Private Type INSSBuffer
    IUnk                        As IUnknown
    GetLength                   As Long
    SetLength                   As Long
    GetMaxLength                As Long
    GetBuffer                   As Long
    GetBufferAndLength          As Long
End Type

Private Type IWMHeaderInfo
    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
End Type

Private Type IWMHeaderInfo2 ' : IWMHeaderInfo
    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
End Type

Private Type IWMHeaderInfo3 ' : IWMHeaderInfo2
    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

Private Type IWMMediaProps
    IUnk                        As IUnknown
    GetType                     As Long
    GetMediaType                As Long
    SetMediaType                As Long
End Type

Private Type IWMInputMediaProps ' : IWMMediaProps
    IUnk                        As IUnknown
    GetType                     As Long
    GetMediaType                As Long
    SetMediaType                As Long
    GetConnectionName           As Long
    GetGroupName                As Long
End Type

Private Type IWMProfileManager
    IUnk                        As IUnknown
    CreateEmtpyProfile          As Long
    LoadProfileByID             As Long
    LoadProfileByData           As Long
    SaveProfile                 As Long
    GetSystemProfileCount       As Long
    LoadSystemProfile           As Long
End Type

Private Type IWMProfile
    IUnk                        As IUnknown
    GetVersion                  As Long
    GetName                     As Long
    SetName                     As Long
    GetDescription              As Long
    SetDescription              As Long
    GetStreamCount              As Long
    GetStream                   As Long
    GetStreamByNumber           As Long
    RemoveStream                As Long
    RemoveStreamByNumber        As Long
    AddStream                   As Long
    ReconfigStream              As Long
    CreateNewStream             As Long
    GetMutualExclusionCount     As Long
    AddMutualExclusion          As Long
    CreateNewMutualExclusion    As Long
End Type

Private Type IWMProfile2 ' : IWMProfile
    IUnk                        As IUnknown
    GetVersion                  As Long
    GetName                     As Long
    SetName                     As Long
    GetDescription              As Long
    SetDescription              As Long
    GetStreamCount              As Long
    GetStream                   As Long
    GetStreamByNumber           As Long
    RemoveStream                As Long
    RemoveStreamByNumber        As Long
    AddStream                   As Long
    ReconfigStream              As Long
    CreateNewStream             As Long
    GetMutualExclusionCount     As Long
    AddMutualExclusion          As Long
    CreateNewMutualExclusion    As Long
    GetProfileID                As Long
End Type

Private Type IWMProfile3
    IUnk                        As IUnknown
    GetVersion                  As Long
    GetName                     As Long
    SetName                     As Long
    GetDescription              As Long
    SetDescription              As Long
    GetStreamCount              As Long
    GetStream                   As Long
    GetStreamByNumber           As Long
    RemoveStream                As Long
    RemoveStreamByNumber        As Long
    AddStream                   As Long
    ReconfigStream              As Long
    CreateNewStream             As Long
    GetMutualExclusionCount     As Long
    AddMutualExclusion          As Long
    CreateNewMutualExclusion    As Long
    GetProfileID                As Long
    GetStorageFormat            As Long
    SetStorageFormat            As Long
    GetBandwidthSharingCount    As Long
    GetBandwidthSharing         As Long
    RemoveBandwidthSharing      As Long
    AddBandwidthSharing         As Long
    CreateNewBandwidthSharing   As Long
    GetStreamPrioritization     As Long
    SetStreamPrioritization     As Long
    RemoveStreamPrioritization  As Long
    CreateNewStreamPrioritization As Long
    GetExpectedPacketCount      As Long
End Type

Private Type IWMCodecInfo
    IUnk                        As IUnknown
    GetCodecInfoCount           As Long
    GetCodecFormatCount         As Long
    GetCodecFormat              As Long
End Type

Private Type IWMCodecInfo2
    IUnk                        As IUnknown
    GetCodecInfoCount           As Long
    GetCodecFormatCount         As Long
    GetCodecFormat              As Long
    GetCodecName                As Long
    GetCodecFormatDesc          As Long
End Type

Private Type IWMStreamConfig
    IUnk                        As IUnknown
    GetStreamType               As Long
    GetStreamNumber             As Long
    SetStreamNumber             As Long
    GetStreamName               As Long
    SetStreamName               As Long
    GetConnectionName           As Long
    SetConnectionName           As Long
    GetBitrate                  As Long
    SetBitrate                  As Long
    GetBufferWindow             As Long
    SetBufferWindow             As Long
End Type

Private Type IWMOutputMediaProps
    IUnk                        As IUnknown
    GetType                     As Long
    GetMediaType                As Long
    SetMediaType                As Long
    GetStreamGroupName          As Long
    GetConnectionName           As Long
End Type

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

Private Type WM_MEDIA_TYPE
    majortype                   As GUID
    subtype                     As GUID
    bFixedSizeSamples           As Long
    bTemporalCompression        As Long
    lSampleSize                 As Long
    formattype                  As GUID
    pUnk                        As Long
    cbFormat                    As Long
    pbFormat                    As Long
End Type


Private Const WMMEDIATYPE_Audio      As String _
    = "{73647561-0000-0010-8000-00AA00389B71}"

Private Const WMMEDIASUBTYPE_PCM     As String _
    = "{00000001-0000-0010-8000-00AA00389B71}"


Private Const WMFORMAT_WaveFormatEx  As String _
    = "{05589f81-c356-11ce-bf01-00aa0055595a}"


Private Const IID_IWMHeaderInfo      As String _
    = "{96406BDA-2B2B-11d3-B36B-00C04F6108FF}"

Private Const IID_IWMHeaderInfo2     As String _
    = "{15CF9781-454E-482e-B393-85FAE487A810}"

Private Const IID_IWMHeaderInfo3     As String _
    = "{15CC68E3-27CC-4ecd-B222-3F5D02D80BD5}"


Private Const IID_IWMProfileManager  As String _
    = "{d16679f2-6ca0-472d-8d31-2f5d55aee155}"

Private Const IID_IWMProfileManager2 As String _
    = "{7A924E51-73C1-494d-8019-23D37ED9B89A}"


Private Const IID_IWMCodecInfo       As String _
    = "{A970F41E-34DE-4a98-B3BA-E4B3CA7528F0}"

Private Const IID_IWMCodecInfo2     As String _
    = "{AA65E273-B686-4056-91EC-DD768D4DF710}"


Private Const IID_IWMMediaProps      As String _
    = "{96406BCE-2B2B-11d3-B36B-00C04F6108FF}"


Private Const WMMEDIASUBTYPE_DRM     As String _
    = "{00000009-0000-0010-8000-00AA00389B71}"



Private Const IID_IUnknown           As String _
    = "{00000000-0000-0000-C000-000000000046}"

Private Const IID_IWMOutputMediaProps As String _
    = "{96406BD7-2B2B-11d3-B36B-00C04F6108FF}"

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

Private Const IID_INSSBuffer         As String _
    = "{E1CD3524-03D7-11d2-9EED-006097D2D7CF}"


Private Const attr_WMDuration    As String = "Duration"
Private Const attr_WMBitrate     As String = "Bitrate"
Private Const attr_WMSeekable    As String = "Seekable"
Private Const attr_WMStridable   As String = "Stridable"
Private Const attr_WMBroadcast   As String = "Broadcast"
Private Const attr_WMProtected   As String = "Is_Protected"
Private Const attr_WMTrusted     As String = "Is_Trusted"
Private Const attr_WMSigName     As String = "Signature_Name"
Private Const attr_WMHasAudio    As String = "HasAudio"
Private Const attr_WMHasImage    As String = "HasImage"
Private Const attr_WMHasScript   As String = "HasScript"
Private Const attr_WMHasVideo    As String = "HasVideo"
Private Const attr_WMCurBitrate  As String = "CurrentBitrate"
Private Const attr_WMOptBitrate  As String = "OptimalBitrate"
Private Const attr_WMSkipBackw   As String = "Can_Skip_Backward"
Private Const attr_WMSkipForw    As String = "Can_Skip_Forward"
Private Const attr_WMNumFrames   As String = "NumberOfFrames"
Private Const attr_WMFileSize    As String = "FileSize"

Private Const attr_WMTitle       As String = "Title"
Private Const attr_WMAuthor      As String = "Author"
Private Const attr_WMDescript    As String = "Description"
Private Const attr_WMRating      As String = "Rating"
Private Const attr_WMCopyright   As String = "Copyright"

Private Const attr_WMAlbumTitle  As String = "WM/AlbumTitle"
Private Const attr_WMAlbumArtist As String = "WM/AlbumArtist"
Private Const attr_WMTrack       As String = "WM/Track"
Private Const attr_WMGenre       As String = "WM/Genre"
Private Const attr_WMYear        As String = "WM/Year"
Private Const attr_WMGenreID     As String = "WM/GenreID"
Private Const attr_WMMCDI        As String = "WM/MCDI"
Private Const attr_WMComposer    As String = "WM/Composer"
Private Const attr_WMLyrics      As String = "WM/Lyrics"
Private Const attr_WMTrackNumber As String = "WM/TrackNumber"
Private Const attr_WMIsVBR       As String = "IsVBR"

' Synchronous WMF Reader
Private IReader                 As IWMSyncReader
Private oReader                 As Long
Private pReaderVTbl             As Long

' Media Properties
Private IProps                  As IWMOutputMediaProps
Private oProps                  As Long
Private pPropsVTbl              As Long

' Media Header
Private IHeader                 As IWMHeaderInfo3
Private oHeader                 As Long
Private pHeaderVTbl             As Long

' waveOut WAVEFORMATEX
Private wfxout                  As MMWAVEFORMATEX

' WMA Attribute
Private curDuration             As Currency
Private curBitrate              As Currency
Private curPosition             As Currency
Private blnSeekable             As Boolean
Private blnEOS                  As Boolean

' PCM Buffer
Private btBuffer()              As Byte
Private lngBufferData           As Long
Private lngPosInBuffer          As Long

' WM Core DLL
Private clsWMCore               As clsDLL

Private blnFileOpened           As Boolean

Private clsTags                 As StreamTags

''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''

Private Function FillBuffer( _
) As Boolean

    Dim lngRet          As Long
    Dim ISample         As INSSBuffer
    Dim oSample         As Long
    Dim pSampleVTbl     As Long
    Dim curSampleDur    As Currency
    Dim pdwFlags        As Long
    Dim pdwOutputNum    As Long
    Dim ppdwBuffer      As Long
    Dim pdwLength       As Long

    If oReader = 0 Then Exit Function

    ' get some PCM samples
    lngRet = CallPointer(IReader.GetNextSample, _
                         oReader, _
                         0, _
                         VarPtr(oSample), _
                         VarPtr(curPosition), _
                         VarPtr(curSampleDur), _
                         VarPtr(pdwFlags), _
                         VarPtr(pdwOutputNum), _
                         0)

    If lngRet <> 0 Then
        blnEOS = lngRet = NS_E_NO_MORE_SAMPLES
        Exit Function
    End If

    ' INSSBuffer's VTable
    CpyMem pSampleVTbl, ByVal oSample, 4
    CpyMem ISample, ByVal pSampleVTbl, Len(ISample)

    ' get a pointer to the decoded samples and their length
    lngRet = CallPointer(ISample.GetBufferAndLength, _
                         oSample, _
                         VarPtr(ppdwBuffer), _
                         VarPtr(pdwLength))

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

    ReDim btBuffer(pdwLength - 1) As Byte
    CpyMem btBuffer(0), ByVal ppdwBuffer, pdwLength

    ' Set INSSBuffer = Nothing
    lngRet = CallPointer(ISample.IUnk.Release, oSample)

    lngPosInBuffer = 0
    lngBufferData = pdwLength

    FillBuffer = True
End Function

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

Private Function GUIDEqual( _
    g1 As GUID, _
    g2 As GUID _
) As Boolean

    GUIDEqual = GUID2Str(g1) = GUID2Str(g2)
End Function

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

Private Sub CpyAttribute( _
    pDst As Long, _
    pSrc As Long, _
    dt As WMT_ATTR_DATATYPE _
)

    Dim nSize   As Long

    Select Case dt
        Case WMT_TYPE_BOOL: nSize = 2
        Case WMT_TYPE_DWORD: nSize = 4
        Case WMT_TYPE_GUID: nSize = 16
        Case WMT_TYPE_QWORD: nSize = 8
        Case WMT_TYPE_WORD: nSize = 2
    End Select

    CpyMem ByVal pDst, ByVal pSrc, nSize
End Sub

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

    If fnc = 0 Then Exit Function

    pASM = VarPtr(btASM(0))

    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

    CallPointer = CallWindowProc(VarPtr(btASM(0)), _
                                 0, 0, 0, 0)
End Function

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

Private Sub Class_Initialize()
    Dim lngRet  As Long

    Set clsWMCore = New clsDLL
    Set clsTags = New StreamTags

    If Not clsWMCore.LoadDLL("wmvcore.dll") Then
        Exit Sub
    End If

    ' create IWMSyncReader instance
    lngRet = clsWMCore.CallFunc("WMCreateSyncReader", _
                                0, _
                                WMT_RIGHT_PLAYBACK, _
                                VarPtr(oReader))

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

    ' IWMSyncReader`s VTable
    CpyMem pReaderVTbl, ByVal oReader, 4
    CpyMem IReader, ByVal pReaderVTbl, Len(IReader)
End Sub

Private Sub Class_Terminate()
    Dim lngRet  As Long

    ISoundStream_StreamClose

    ' Set IWMSyncReader = Nothing
    If oReader <> 0 Then
        CallPointer IReader.IUnk.Release, oReader
    End If

    clsWMCore.UnloadDLL
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''

Private Property Get ISoundInfo_BitsPerSample( _
) As Integer

    ISoundInfo_BitsPerSample = wfxout.wBitsPerSample
End Property

Private Property Get ISoundInfo_BitsPerSecond( _
) As Long

    ISoundInfo_BitsPerSecond = curBitrate * 10000
End Property

Private Property Get ISoundInfo_channels( _
) As Integer

    ISoundInfo_channels = wfxout.nChannels
End Property

Private Property Get ISoundInfo_Duration( _
) As Long

    ISoundInfo_Duration = curDuration
End Property

Private Property Get ISoundInfo_Position( _
) As Long

    ISoundInfo_Position = curPosition
End Property

Private Property Get ISoundInfo_SamplesPerSecond( _
) As Long

    ISoundInfo_SamplesPerSecond = wfxout.nSamplesPerSec
End Property

Private Property Get ISoundInfo_Tags( _
) As StreamTags

    Set ISoundInfo_Tags = clsTags
End Property

''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''

Private Property Get ISoundStream_Description( _
) As String

    ISoundStream_Description = Description
End Property

Private Property Get ISoundStream_EndOfStream( _
) As Boolean

    ISoundStream_EndOfStream = blnEOS
End Property

Private Function ISoundStream_Extensions( _
) As String()

    ISoundStream_Extensions = Split(Extensions, ";")
End Function

Private Function ISoundStream_QuickStreamInfo( _
    ByVal Source As String, info As ISoundInfo _
) As SND_RESULT

    ' WMA stream is too slow to gather information
    ' while playing songs

    Dim clsInfo     As QuickStreamInfo

    Set clsInfo = New QuickStreamInfo
    Set info = clsInfo

    clsInfo.SetValues 0, 0, 0, 0, 0, 0, New StreamTags

    ISoundStream_QuickStreamInfo = SND_ERR_SUCCESS
End Function

Private Function ISoundStream_StreamClose( _
) As SND_RESULT

    Dim lngRet  As Long

    If oReader = 0 Then
        ISoundStream_StreamClose = SND_ERR_INTERNAL
        Exit Function
    End If

    If Not blnFileOpened Then
        ISoundStream_StreamClose = SND_ERR_INVALID_SOURCE
        Exit Function
    End If

    lngRet = CallPointer(IReader.Close, oReader)
    blnFileOpened = False

    blnEOS = False
    lngBufferData = 0
    lngPosInBuffer = 0

    clsTags.ClearTags

    ISoundStream_StreamClose = SND_ERR_SUCCESS
End Function

Private Property Get ISoundStream_StreamInfo( _
) As ISoundInfo

    Set ISoundStream_StreamInfo = Me
End Property

Private Function ISoundStream_StreamOpen( _
    ByVal Source As String _
) As SND_RESULT

    Dim lngRet  As Long

    If oReader = 0 Then
        ISoundStream_StreamOpen = SND_ERR_INTERNAL
        Exit Function
    End If

    If Not IsValidFile(Source) Then
        ISoundStream_StreamOpen = SND_ERR_INVALID_SOURCE
        Exit Function
    End If

    ' open the file
    lngRet = CallPointer(IReader.Open, _
                         oReader, _
                         StrPtr(Source))

    If lngRet <> 0 Then
        ISoundStream_StreamOpen = SND_ERR_INVALID_SOURCE
        Exit Function
    End If

    If Not GetOutputFormat() Then
        CallPointer IReader.Close, oReader
        ISoundStream_StreamOpen = SND_ERR_UNKNOWN
        Exit Function
    End If

    ' range to decode (0 to EOF)
    lngRet = CallPointer(IReader.SetRangeByFrame, _
                         oReader, _
                         1, 0, 0, _
                         0, 0)

    If lngRet <> 0 Then
        lngRet = CallPointer(IReader.Close, oReader)
        ISoundStream_StreamOpen = SND_ERR_UNKNOWN
        Exit Function
    End If

    If Not GetAttributes Then
        lngRet = CallPointer(IReader.Close, oReader)
        ISoundStream_StreamOpen = SND_ERR_UNKNOWN
        Exit Function
    End If

    blnFileOpened = True

    ISoundStream_StreamOpen = SND_ERR_SUCCESS
End Function

Private Function GetAttributes( _
) As Boolean

    Dim lngRet      As Long
    Dim cAttrs      As Long
    Dim attIndex    As Long
    Dim cchName     As Long
    Dim cbValue     As Long

    Dim pwszName    As String
    Dim strValue    As String

    Dim pbValue()   As Byte

    Dim attType     As WMT_ATTR_DATATYPE

    Dim iid_hdr     As GUID

    clsTags.ClearTags

    ' get IWMHeaderInfo3 from IWMSyncReader
    iid_hdr = Str2GUID(IID_IWMHeaderInfo3)
    lngRet = CallPointer(IReader.IUnk.QueryInterface, _
                         oReader, _
                         VarPtr(iid_hdr), _
                         VarPtr(oHeader))

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

    ' number of attributes
    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

        ' size of the attribute
        lngRet = CallPointer(IHeader.GetAttributeByIndexEx, _
                             oHeader, _
                             &HFFFF&, _
                             attIndex, _
                             0, _
                             VarPtr(cchName), _
                             0, 0, 0, _
                             VarPtr(cbValue))

        If lngRet <> 0 Then GoTo NextAttribute

        ' get some memory for the attribute
        pwszName = Space(cchName)
        ReDim pbValue(cbValue - 1) As Byte

        ' read the attribute
        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 = RemNullChars(pwszName)

        Select Case attType
            Case WMT_TYPE_WORD                  ' integer
                Dim intVal  As Integer
                CpyMem intVal, pbValue(0), 2
                strValue = intVal
            Case WMT_TYPE_DWORD                 ' long
                Dim lngVal  As Long
                CpyMem lngVal, pbValue(0), 4
                strValue = lngVal
            Case WMT_TYPE_QWORD                 ' currency?
                Dim curVal  As Currency
                CpyMem curVal, pbValue(0), 8
                strValue = curVal
            Case WMT_TYPE_STRING                ' Unicode String
                strValue = RemNullChars(pbValue)
            Case WMT_TYPE_BINARY                ' binary...
                ' nicht lesbar...
                ' Debug.Print "<binary>"
            Case WMT_TYPE_BOOL                  ' boolean
                CpyMem lngVal, pbValue(0), cbValue
                strValue = CBool(lngVal)
            Case WMT_TYPE_GUID                  ' global unique identifier
                Dim G   As GUID
                CpyMem G, pbValue(0), Len(G)
                strValue = GUID2Str(G)
        End Select

        ' Attributes we want to save
        Select Case pwszName

            Case attr_WMDuration
                CpyAttribute VarPtr(curDuration), _
                             VarPtr(pbValue(0)), _
                             attType

            Case attr_WMBitrate
                CpyAttribute VarPtr(curBitrate), _
                             VarPtr(pbValue(0)), _
                             attType

            Case attr_WMSeekable
                CpyAttribute VarPtr(blnSeekable), _
                             VarPtr(pbValue(0)), _
                             attType

            Case attr_WMAuthor
                clsTags.AddTag "artist", strValue

            Case attr_WMAlbumArtist
                clsTags.AddTag "artist", strValue

            Case attr_WMAlbumTitle
                clsTags.AddTag "album", strValue

            Case attr_WMGenre
                clsTags.AddTag "genre", strValue

            Case attr_WMTitle
                clsTags.AddTag "title", strValue

            ' Tracknumber seems to get saved as DWORD
            ' pretty often, even though it is an
            ' string attribute.
            Case attr_WMTrackNumber
                CpyMem lngVal, pbValue(0), 4

                If lngVal > 48 Then
                    clsTags.AddTag "tracknumber", strValue
                Else
                    clsTags.AddTag "tracknumber", Chr$(lngVal)
                End If

            Case attr_WMDescript
                clsTags.AddTag "comment", strValue

            Case attr_WMYear
                clsTags.AddTag "year", strValue

        End Select

NextAttribute:
    Next

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

    GetAttributes = True
End Function

Private Function GetOutputFormat( _
) As Boolean

    Dim lngRet      As Long
    Dim pcOutputs   As Long
    Dim pcFormats   As Long
    Dim pcbType     As Long
    Dim i           As Long
    Dim j           As Long
    Dim MediaType   As WM_MEDIA_TYPE

    Dim btMT()      As Byte

    ' number of outputs
    lngRet = CallPointer(IReader.GetOutputCount, _
                         oReader, _
                         VarPtr(pcOutputs))

    If lngRet <> 0 Then
        lngRet = CallPointer(IReader.Close, oReader)
        Exit Function
    End If

    ' formats of each output
    For i = 0 To pcOutputs - 1

        lngRet = CallPointer(IReader.GetOutputFormatCount, _
                             oReader, _
                             i, _
                             VarPtr(pcFormats))

        If lngRet <> 0 Then GoTo NextOutput

        ' details for each format
        For j = 0 To pcFormats

            ' create IWMOutputMediaProps instance
            lngRet = CallPointer(IReader.GetOutputFormat, _
                                 oReader, _
                                 j, i, _
                                 VarPtr(oProps))

            If lngRet <> 0 Then GoTo NextFormat

            ' IWMOutputMediaProps`s VTable
            CpyMem pPropsVTbl, ByVal oProps, 4
            CpyMem IProps, ByVal pPropsVTbl, Len(IProps)

            ' it is not allowed to simply request
            ' a WM_MEDIA_TYPE struct.
            ' You first need to ask for the size of
            ' WM_MEDIA_TYPE to make sure your buffer
            ' is big enough to hold it.

            lngRet = CallPointer(IProps.GetMediaType, _
                                 oProps, _
                                 0, _
                                 VarPtr(pcbType))

            If lngRet <> 0 Then
                lngRet = CallPointer(IProps.IUnk.Release, oProps)
                oProps = 0
                GoTo NextFormat
            Else
                ReDim btMT(pcbType - 1) As Byte
            End If

            lngRet = CallPointer(IProps.GetMediaType, _
                                 oProps, _
                                 VarPtr(btMT(0)), _
                                 VarPtr(pcbType))

            CpyMem MediaType, btMT(0), Len(MediaType)

            ' Audio?
            If GUIDEqual(MediaType.majortype, Str2GUID(WMMEDIATYPE_Audio)) Then
                ' PCM?
                If GUIDEqual(MediaType.subtype, Str2GUID(WMMEDIASUBTYPE_PCM)) Then
                    ' 16 Bit?
                    CpyMem wfxout, ByVal MediaType.pbFormat, Len(wfxout)
                    If wfxout.wBitsPerSample = 16 Then
                        lngRet = CallPointer(IProps.SetMediaType, oProps, VarPtr(btMT(0)))
                        GoTo ExitLoops
                    End If
                End If
            End If

            ' Set IWMOutputMediaProps = Nothing
            lngRet = CallPointer(IProps.IUnk.Release, oProps)
            oProps = 0

NextFormat:         ' Not beautiful,
        Next j

NextOutput:         ' but makes nested loops
    Next i
ExitLoops:          ' very easy to control.

    ' no format found?
    If i = pcOutputs Then
        Exit Function
    End If

    ' set new output format
    lngRet = CallPointer(IReader.SetOutputProps, oReader, i, oProps)
    lngRet = CallPointer(IProps.IUnk.Release, oProps)
    oProps = 0

    GetOutputFormat = True
End Function

Private Function ISoundStream_StreamRead( _
    ByVal buffer_ptr As Long, _
    ByVal buffer_len As Long, _
    buffer_read As Long _
) As SND_RESULT

    ISoundStream_StreamRead = SND_ERR_SUCCESS

    buffer_read = 0

    Do While buffer_read < buffer_len

        If lngBufferData = 0 Then
            If Not FillBuffer Then
                ISoundStream_StreamRead = SND_ERR_END_OF_STREAM
                Exit Function
            End If

        ElseIf (lngBufferData - lngPosInBuffer) < (buffer_len - buffer_read) Then
            If 0 < (lngBufferData - lngPosInBuffer) Then

                If 0 = IsBadReadPtr(ByVal VarPtr(btBuffer(0)) + lngPosInBuffer, _
                                    lngBufferData - lngPosInBuffer) Then

                    If 0 = IsBadWritePtr(ByVal buffer_ptr + buffer_read, _
                                         lngBufferData - lngPosInBuffer) Then

                        CpyMem ByVal buffer_ptr + buffer_read, _
                               ByVal VarPtr(btBuffer(0)) + lngPosInBuffer, _
                               lngBufferData - lngPosInBuffer

                    End If
                End If

                buffer_read = buffer_read + (lngBufferData - lngPosInBuffer)
            End If

            If Not FillBuffer Then
                ISoundStream_StreamRead = SND_ERR_END_OF_STREAM
                Exit Function
            End If

        Else
            If 0 = IsBadReadPtr(ByVal VarPtr(btBuffer(0)) + lngPosInBuffer, _
                                buffer_len - buffer_read) Then

                If 0 = IsBadWritePtr(ByVal buffer_ptr + buffer_read, _
                                     buffer_len - buffer_read) Then

                    CpyMem ByVal buffer_ptr + buffer_read, _
                           ByVal VarPtr(btBuffer(0)) + lngPosInBuffer, _
                           buffer_len - buffer_read

                End If
            End If

            lngPosInBuffer = lngPosInBuffer + (buffer_len - buffer_read)
            buffer_read = buffer_read + (buffer_len - buffer_read)

        End If

    Loop
End Function

Private Function ISoundStream_StreamSeek( _
    ByVal Value As Long, _
    ByVal seek_mode As SND_SEEK_MODE _
) As SND_RESULT

    Dim curTime     As QWORD, curTime0  As QWORD
    Dim dblTime     As Double, strHex   As String
    Dim lngRet      As Long

    Select Case seek_mode

        Case SND_SEEK_PERCENT
            If Value < 0 Or Value > 99 Then
                ISoundStream_StreamSeek = SND_ERR_OUT_OF_RANGE
                Exit Function
            End If

            ' Position in 100-Nanoseconds
            dblTime = Fix(curDuration / CDbl(100) * CDbl(Value) * 10000#)

        Case SND_SEEK_SECONDS
            If Value < 0 Or Value > (ISoundInfo_Duration / 1000) Then
                ISoundStream_StreamSeek = SND_ERR_OUT_OF_RANGE
                Exit Function
            End If

            ' Position in 100-Nanoseconds
            dblTime = Fix(curDuration / CDbl(100) * CDbl(Value / (ISoundInfo_Duration / 1000) * 100) * 10000#)

    End Select

    ' Base 10 to Base 16
    strHex = FmtStrLen(DecToHex(dblTime), 16)

    ' lo DWORD
    curTime.lo = Val("&H" & Right$(strHex, 8) & "&")
    ' hi DWORD
    curTime.hi = Val("&H" & Left$(strHex, 8) & "&")

    ' set new position
    lngRet = CallPointer(IReader.SetRange, oReader, _
                         curTime.lo, curTime.hi, _
                         curTime0.lo, curTime0.hi)

    If lngRet = 0 Then
        FillBuffer
        ISoundStream_StreamSeek = SND_ERR_SUCCESS
    Else
        ISoundStream_StreamSeek = SND_ERR_OUT_OF_RANGE
    End If
End Function

Implements ISoundStream

Code:

Option Explicit

Public Enum SND_RESULT
    SND_ERR_SUCCESS = 0
    SND_ERR_INVALID_SOURCE
    SND_ERR_INVALID_OUTPUT
    SND_ERR_INTERNAL
    SND_ERR_OUT_OF_RANGE
    SND_ERR_END_OF_STREAM
    SND_ERR_INVALID_TAG
    SND_ERR_INVALID_PARAM
    SND_ERR_TOO_BIG
    SND_ERR_NEED_MORE
    SND_ERR_INVALID_BUFFER
    SND_ERR_WRITE_ERROR
    SND_ERR_UNKNOWN
End Enum

Public Enum SND_SEEK_MODE
    SND_SEEK_PERCENT = 0
    SND_SEEK_SECONDS
End Enum

Public Property Get StreamInfo( _
) As ISoundInfo

End Property

Public Property Get EndOfStream( _
) As Boolean

End Property

Public Property Get Description( _
) As String

End Property

Public Function Extensions( _
) As String()

End Function

Public Function QuickStreamInfo( _
    ByVal Source As String, _
    info As ISoundInfo _
) As SND_RESULT

End Function

Public Function StreamOpen( _
    ByVal Source As String _
) As SND_RESULT

End Function

Public Function StreamClose( _
) As SND_RESULT

End Function

Public Function StreamSeek( _
    ByVal value As Long, _
    ByVal seek_mode As SND_SEEK_MODE _
) As SND_RESULT

End Function

Public Function StreamRead( _
    ByVal buffer_ptr As Long, _
    ByVal buffer_len As Long, _
    ByRef buffer_read As Long _
) As SND_RESULT

End Function

Implements ISoundInfo

Code:

Option Explicit

Public Property Get SamplesPerSecond( _
) As Long

End Property

Public Property Get Channels( _
) As Integer

End Property

Public Property Get BitsPerSample( _
) As Integer

End Property

Public Property Get BitsPerSecond( _
) As Long

End Property

Public Property Get position( _
) As Long

End Property

Public Property Get Duration( _
) As Long

End Property

Public Property Get tags( _
) As StreamTags

End Property

grüße und viel Spass beim übersetzen !!!

[KingIR]

Mein Gott, für solche Späße schreibt man doch ne C++-Dll, die man dann von VB aus aufruft... Und hackt sich nicht sowas zusammen... Das ist ja schlimm was für Sachen das arme, unschuldige VB da über sich ergehen lassen muss!
(Nicht ganz ernst gemeint, aber ist schon heftig der Code, Respekt an den Autor )

Danke auf jeden Fall, mal sehen ob sich was draus basteln lässt