Late Bound Windows Media Player going out of scope

[Jaafar Tribak]

Hi,

This works:

Dim oMPlayer As Object

Sub test1()
    Set oMPlayer = CreateObject("New:{6BF52A52-394A-11D3-B153-00C04F79FAA6}")
    With oMPlayer
        .URL = "C:\test\Alarm02.wav"
         Debug.Print .currentMedia.Name
    End With
End Sub

This doesn't work as it doesn't store the media player in a module level variable.

Sub test2()
    With CreateObject("New:{6BF52A52-394A-11D3-B153-00C04F79FAA6}")
        .URL = "C:\test\Alarm02.wav"
         Debug.Print .currentMedia.Name
    End With
End Sub

.OpenPlayer "C:\test\Alarm02.wav" Method works but it shows the media player window unlike the URL Property... This is similar to what happens when opening a new excel instance (late bound) without setting the Visible Property to TRUE.

Is there some MPlayer Method or Property that can be set (or some other workaround) to make the test2 macro work - ie:= w/o storing the MPlayer instance in a module level variable and w/o making it visible ?

Regards.

 

[Georgiboy]

test2 is working for me, in regards to: it plays the sound without loading MP and also returns the '.currentMedia.Name'

I did have my .Wav file saved in a folder on my desktop, if that makes a difference.

 

[sancarn]

@jaafer have you tried calling IUnknown::AddRef() ? This should at least make the object persist (I would anticipate)

 

[Jaafar Tribak]

@Georgiboy
It didn't work for me. The MPlayer is loaded (that's why I called .currentMedia.Name to confirm the loading of the MPlayer) but it goes out of scope before the URL Property gets a chance to play the wav file.

Thanks for testing.

 

[Georgiboy]

How about something like the below, or does that defeat the object?

Public Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Sub test()
    PlaySound "C:\test\Alarm02.wav", 0
End Sub

 

[Jaafar Tribak]

How about something like the below, or does that defeat the object?

Public Declare PtrSafe Function PlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Sub test()
    PlaySound "C:\test\Alarm02.wav", 0
End Sub

Yes. The PlaySound api will work as well as using MCI Command Strings but I am just curious as to how to make this work using the WMPlayer or rather how to solve the issue of the object going out of scope prematurely

sancarn has kindly drawn my attention to what seems to be the solution for preventing the object to go out of scope although it is going to be a bit involved.
Thank you.

 

[Georgiboy]

I will let you crack on with the solution then.

 

[Jaafar Tribak]

Ok - I have managed to prevent the WMPlayer from going out of scope by calling the IUnknown::AddRef function as kindly suggested by sancarn.
To make this work, I had to use the DispCallFunc api which is rather involved .

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare PtrSafe Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal offsetinVft As LongPtr, ByVal CallConv As Long, ByVal retTYP As Integer, ByVal paCNT As Long, ByRef paTypes As Integer, ByRef paValues As LongPtr, ByRef retVAR As Variant) As Long
    Private Declare Sub SetLastError Lib "kernel32.dll" (ByVal dwErrCode As Long)
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As Long
#End If

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

Sub test2()

    #If Win64 Then
        Const PTR_LEN = 8&
    #Else
        Const PTR_LEN = 4&
    #End If
    Const CC_STDCALL As Long = 4&, S_OK = 0&
    Const IID_IUNKNOWN = "{00000000-0000-0000-C000-000000000046}"
    Dim tGUID(0& To 11&) As Long
    Dim oMPlayer As Object
    
    Call IIDFromString(StrPtr(IID_IUNKNOWN), VarPtr(tGUID(0&)))
    Set oMPlayer = CreateObject("New:{6BF52A52-394A-11D3-B153-00C04F79FAA6}")
    'Call IUKnown::AddRef (VTable Offset = 4 bytes in x32 Processes and 8 bytes in x64 Processes)
    If vtblCall(ObjPtr(oMPlayer), PTR_LEN, vbLong, CC_STDCALL) > 1& Then
        With oMPlayer
            .URL = "C:\test\Alarm02.wav"
            Debug.Print .currentMedia.Name
        End With
    End If
  
End Sub

Private Function vtblCall( _
    ByVal InterfacePointer As LongPtr, _
    ByVal VTableOffset As Long, _
    ByVal FunctionReturnType As Long, _
    ByVal CallConvention As Long, _
    ParamArray FunctionParameters() As Variant _
) As Variant

    Dim vParamPtr() As LongPtr

    If InterfacePointer = 0& Or VTableOffset < 0& Then Exit Function
    If Not (FunctionReturnType And &HFFFF0000) = 0& Then Exit Function

    Dim pIndex As Long, pCount As Long
    Dim vParamType() As Integer
    Dim vRtn As Variant, vParams() As Variant

    vParams() = FunctionParameters()
    pCount = Abs(UBound(vParams) - LBound(vParams) + 1&)
    If pCount = 0& Then
        ReDim vParamPtr(0 To 0)
        ReDim vParamType(0 To 0)
    Else
        ReDim vParamPtr(0 To pCount - 1&)
        ReDim vParamType(0 To pCount - 1&)
        For pIndex = 0& To pCount - 1&
            vParamPtr(pIndex) = VarPtr(vParams(pIndex))
            vParamType(pIndex) = VarType(vParams(pIndex))
        Next
    End If

    pIndex = DispCallFunc(InterfacePointer, VTableOffset, CallConvention, FunctionReturnType, pCount, _
    vParamType(0), vParamPtr(0), vRtn)
    If pIndex = 0& Then
        vtblCall = vRtn
    Else
        SetLastError pIndex
    End If

End Function

But to my surprise, I have tested and successfully come up with a much easier (and shorter) method w/o the need to use the long winded DispCallFunc wrapper... I see the potential of this stuff about preserving objects in memory and preventing them from going out of scope and I can think of various situations where this can be very useful.

I will post this easier method next.

 

[Jaafar Tribak]

This is the magic api function called CoLockObjectExternal exported by the ole32.dll... Nice & short !

Option Explicit

'HRESULT CoLockObjectExternal(
'  [in] LPUNKNOWN pUnk,
'  [in] BOOL      fLock,
'  [in] BOOL      fLastUnlockReleases
');

#If VBA7 Then
    Declare PtrSafe Function CoLockObjectExternal Lib "ole32.dll" (ByVal pUnk As IUnknown, ByVal fLock As Boolean, Optional ByVal fLastUnlockReleases As Boolean) As Long
#Else
    Declare Function CoLockObjectExternal Lib "ole32.dll" (ByVal pUnk As IUnknown, ByVal fLock As Boolean, Optional ByVal fLastUnlockReleases As Boolean) As Long
#End If

Sub test2()
    Const S_OK = 0&
    Dim oMPlayer As Object
    Set oMPlayer = CreateObject("New:{6BF52A52-394A-11D3-B153-00C04F79FAA6}")
    'Call CoLockObjectExternal to lock the MPlayer object to ensure that it stays in memory.
    If CoLockObjectExternal(oMPlayer, True) = S_OK Then
        With oMPlayer
            .URL = "C:\test\Alarm02.wav"
            Debug.Print .currentMedia.Name
        End With
    End If
End Sub

In theory and according to the documentation, the lock should be released which I am not doing here since it will defeat the purpose so I am not sure if that's ok. I have carried out a few tests w/o any issues so far ... The same goes with the previous IUnKnown::AddRef method which in theory should be followed by IUnKnown::Release when done.

Thanks everyone for their help.

 

[Dan_W]

Is this the same issue as with losing the connection with the Ribbon - and couldn't the method used by RoryA to save/retrieve the pointer from a Name work here too?

As an aside, I've recently come across the Active Movie Control type library, thought I'd share it here for fun.

' Requires a reference to Active Movie Control Type Library (quartz.dll)
Private Type IMediaType
    Control     As IMediaControl
    Position    As IMediaPosition
    Audio       As IBasicAudio
End Type

Private IMedia As IMediaType

Sub Test()
    Dim FileName As String
    FileName = "D:\TwinkleTwinkle.wav"
    LoadSoundFile FileName
    DestroyFile
End Sub

Private Sub LoadSoundFile(ByVal FileName As String, Optional ByVal Volume As Long = -2000)

    Set IMedia.Control = New FilgraphManager
    IMedia.Control.RenderFile FileName
    Set IMedia.Audio = IMedia.Control
    Set IMedia.Position = IMedia.Control
    IMedia.Position.Rate = 1
    IMedia.Position.CurrentPosition = 0
    IMedia.Control.Run
    IMedia.Audio.Volume = Volume
    Debug.Print IMedia.Position.CurrentPosition
    Debug.Print IMedia.Position.Duration
End Sub

Private Sub DestroyFile()
    Set IMedia.Audio = Nothing
    Set IMedia.Position = Nothing
    Set IMedia.Control = Nothing
End Sub