Play embedded wav file when workbook opens but without showing the media player

[BlondieC]

Running Excel 2013.

I've done quite a bit of searching on this one this morning and from most of the info I read it doesn't look like this can be done. However, most of the info was years old so I'm hoping over the years something changed and I will be able to have this work successfully.

I don't include sound in my Excel reports but this is a special case. We have a product launch of sorts coming up and for the first report I send out on these products I wanted to have a wav play when the end user opens the workbook.

I have the wav embedded and some code and it works with one exception... the media player pops up asking with an "Open Package Contents" window asking "Do you want to open this file?, Open or Cancel".

I would really prefer if for the end user it just played without being prompted by the Media Player.

My code is placed in "ThisWorkbook".

Private Sub Workbook_Open()Application.DisplayAlerts = False
ActiveSheet.Shapes("Object 1").Select
Selection.Verb Verb:=xlPrimary
Application.DisplayAlerts = True
End Sub

Thank you.

 

[Jaafar Tribak]

I copied the embedded wav object to the clipboard and looked in the ClipBoard viewer and found that excel has what seems to be an application defined clipboard format called Native ... the data associated with this format has the RIFF word. According to the MS documentation, The CF_RIFF CF 'represents audio data more complex than can be represented in a CF_WAVE standard wave format.'

After some trial and error, I found that the actual wav file data starts at the same byte as that of the RIFF word so I extracted the data from that location onwards into a byte buffer via the GetClipboardData and CopyMemory APIs and then passed the buffer to the sndPlaySound function in its first parameter. Result: It worked !

I have tested the Play function below with different embedded wav objects and they all played their sound as expected

In a standard module:

Option Explicit


#If VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Declare PtrSafe Function waveOutGetNumDevs Lib "winmm.dll" () As Long
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" (lpszSoundName As Any, ByVal uFlags As Long) As Long
    Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
#End If


Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_MEMORY = &H4


Public Function Play(WAVOleObject As OLEObject) As Boolean
    #If VBA7 Then
        Dim hClipMem As LongPtr, lMemSize As LongPtr, lMemPtr As LongPtr
    #Else
        Dim hClipMem As Long, lMemSize As Long, lMemPtr As Long
    #End If
    Dim bytBuffer() As Byte
    Const CF_NATIVE = &HC004&


    WAVOleObject.Copy
    DoEvents
    If OpenClipboard(0) Then
        hClipMem = GetClipboardData(CF_NATIVE)
        If hClipMem Then lMemSize = GlobalSize(hClipMem)
        If lMemSize Then lMemPtr = GlobalLock(hClipMem)
        If lMemPtr Then
            ReDim bytBuffer(0 To CLng(lMemSize) - 1) As Byte
            CopyMemory bytBuffer(0), ByVal lMemPtr, lMemSize
            If waveOutGetNumDevs > 0 Then
                sndPlaySound bytBuffer(InStr(StrConv(bytBuffer, vbUnicode), "RIFF") - 1), _
                SND_ASYNC Or SND_NODEFAULT Or SND_MEMORY
                Play = True
            End If
            Call GlobalUnlock(hClipMem)
        End If
        Call EmptyClipboard
        Call CloseClipboard
    End If
End Function

Working example :

Sub Test()
    If Play(Worksheets(1).OLEObjects("Objet 1")) = False Then
        MsgBox "Unable to play the embedded wav object", vbCritical
    End If
End Sub

 

[RickXL]

Great stuff, Jaafar!

I had found this link which is not a million miles away: Solved: Playing Embedded Wav File [Archive] - VBA Express Forum
But all I could make it do was save a file that Windows would not play.

I did not realise that sndPlaySound would play a sound from a byte string and I did not have the patience to compare the embedded file with the original sound to spot the differences.

I think I am going to have to file this in my "Examples" library.

I have now added the following code into my ThisWorkbook module and so the workbook announces itself when it is opened.

Private Sub Workbook_Open()
    Call Play(Worksheets(1).OLEObjects(1))
End Sub

Thanks for sorting it all out.

Regards,

 

[Jaafar Tribak]

Thanks RickXL for the feedback ... I am glad this worked as I myself needed this in a small project a few months ago

I remember seeing the posts in the vbaexpress link a few months ago but I haven't been able to make it work until I downloaded a Clipboard viewer and inspected the copied wav data bytes

did not realise that sndPlaySound would play a sound from a byte string

Lookup the SND_MEMORY Constant

This however doesn't work for other embedded audio file types like midi, mp4 files ... but I can think of an ugly hack ... If anything comes up I'll post it here

 

[Jaafar Tribak]

I played a little bit further with this over the weekend in order to have a generic function that not only does it play wav files as shown in my previous post but plays all audio file formats

Basically, this is how this code works :

The code starts by copying the embedded OLEObject to the clipboard... Windows automatically creates a temporary audio file in the Temp folder as soon as the copying takes place... Since we now have a propper audio file in the Temp folder we should be able to pass its file path to the mciSendString API function and play the audio

However we now face a problem: We don't know the exact file name that was given by Windows to our target audio file plus there may be other audio files with a similar name/the same extension ... In order to overcome this issue, we go back to the clipboard and extract the actual audio file string from it by using the GetShortPathName API

I tested this code with .wav, .midi and .mp3 audio files and all plyaed smoothly behind the scenes

Place this in a standard module and run the PlayAudioTest Macro

Option Explicit

#If VBA7 Then
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
    Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Declare PtrSafe Function waveOutGetNumDevs Lib "winmm.dll" () As Long
    Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
    Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
#Else
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
    Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Declare Function waveOutGetNumDevs Lib "winmm.dll" () As Long
    Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
    Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
#End If




Public Sub PlayAudioTest()
    If Not Play(Worksheets(1).OLEObjects("Object 1")) Then
        MsgBox "Unable to Play the OLEObject Audio."
    End If
End Sub


Public Sub StopAudioFile()
    Call mciSendString("stop EmbeddedAudio", 0, 0, 0)
    Call mciSendString("close EmbeddedAudio", 0, 0, 0)
End Sub




Function Play(AudioOleObject As OLEObject) As Boolean
    #If VBA7 Then
        Dim hClipMem As LongPtr, lMemSize As LongPtr, lMemPtr As LongPtr
    #Else
        Dim hClipMem As Long, lMemSize As Long, lMemPtr As Long
    #End If
    
    Dim bytBuffer() As Byte
    Const CF_NATIVE = &HC004&
    
    On Error GoTo errHandler
    If AudioOleObject.OLEType = xlOLEEmbed Then
        If waveOutGetNumDevs > 0 Then
            AudioOleObject.Copy
            DoEvents
            If OpenClipboard(0) Then
                hClipMem = GetClipboardData(CF_NATIVE)
                If hClipMem Then
                    lMemSize = GlobalSize(hClipMem)
                    If lMemSize Then
                        lMemPtr = GlobalLock(hClipMem)
                        If lMemPtr Then
                            ReDim bytBuffer(0 To CLng(lMemSize) - 1) As Byte
                            CopyMemory bytBuffer(0), ByVal lMemPtr, lMemSize
                            If PlayAudioFile(ExtractFilePathName(StrConv(bytBuffer, vbUnicode))) Then
                                Play = True
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
errHandler:
    Call GlobalUnlock(hClipMem)
    Call EmptyClipboard
    Call CloseClipboard
End Function


Function PlayAudioFile(ByVal AudioFile As String) As Boolean
    Dim lRes As Long, sPath As String
    
    sPath = String$(255, 0)
    lRes = GetShortPathName(AudioFile, sPath, 255)
    Call mciSendString("stop EmbeddedAudio", 0, 0, 0)
    Call mciSendString("close EmbeddedAudio", 0, 0, 0)
    If mciSendString("open " & Left$(sPath, lRes) & " alias EmbeddedAudio", 0, 0, 0) = 0 Then
        If mciSendString("play EmbeddedAudio", 0, 0, 0) = 0 Then
            PlayAudioFile = True
        End If
    End If
End Function


Function ExtractFilePathName(ByVal sText As String) As String
    Dim i As Integer
    
    sText = Right(sText, Len(sText) + 1 - InStr(1, sText, Environ("temp")))
    i = 1
    Do While Not Mid(sText, i, 5) Like ".***" & Chr(0)
        i = i + 1
        DoEvents
    Loop
    ExtractFilePathName = Trim(Left(sText, i + 3))
End Function

 

[RickXL]

Thanks Jaafar. I spy serious amounts of detective work there!

I quoted this post in this question: http://www.mrexcel.com/forum/excel-questions/941857-ole-objects-path-file-location.html#post4528393 and I remembered that I had not replied to this thread although I had intended to.

Combining the ideas from the two posts I have come up with another possible solution although I am not sure how foolproof it would be in practice. I used the slightly outdated sndPlaySound program and told it to play a temporary version of the wav file in the Temporary Folder:

Option Compare Text

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
        (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
        
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10

Sub PlayEmbeddedWav()
    Dim OLEobj     As OLEObject
    Dim objFSO     As Object
    Dim objFile    As File
    Dim rc         As Long
    Debug.Print Now
    Set OLEobj = Sheet1.OLEObjects(1).Duplicate
    Set OLEobj = OLEobj.Duplicate
    OLEobj.Delete
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(Environ("Tmp") & "\").Files
        If objFile.Name Like "*.wav" Then
            If objFile.DateCreated > (Now - TimeValue("00:00:05")) Then
                rc = sndPlaySound(objFile.Path, CLng(SND_SYNC Or SND_NODEFAULT))
                objFile.Delete
            End If
        End If
    Next
End Sub

Basically, OLEobj.Duplicate forces a copy of the embedded file to be placed in the Temporary Folder. The duplicated icon is removed from the worksheet.
The loop then looks for a recent .wav file in the Temporary Folder and plays it.

 

[RickXL]

An update.

I managed to include two .Duplicate methods above.
Also, the code did not work if you tried to run it twice quickly.
Strangely, although the file name was removed from Explorer, when the second run of the code took place the file re-appeared with the original CreatedDate (and time). Changing that to DateLastModified seems to have fixed it.

Apologies.

Option Compare Text

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
        (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
        
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10

Sub PlayEmbeddedWav()
    Dim OLEobj     As OLEObject
    Dim objFSO     As Object
    Dim objFile    As File
    Dim rc         As Long

    Set OLEobj = Sheet1.OLEObjects(1).Duplicate
    OLEobj.Delete
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    For Each objFile In objFSO.GetFolder(Environ("Tmp") & "\").Files
        If objFile.Name Like "*.wav" And objFile.DateLastModified > (Now - TimeValue("00:00:01")) Then
            rc = sndPlaySound(objFile.Path, CLng(SND_SYNC Or SND_NODEFAULT))
            objFile.Delete
        End If
    Next
End Sub

 

[Jaafar Tribak]

Sorry Rick for not responding to your postings earlier .... I actually haven't visited the forum for a few days

I would be wary of using the DateLastModified or DateCreated for retrieving our targeted files when these are located in the Temp folder as I found this method to yield inconsistent results

Maybe, an alternative would be to copy the embeeded object and pasting it inside a newly created folder ... For this, on could use the InvokeVerb Method of the Folder namespace of the Shell ... I posted an example a while ago in the following thread - see post 3

http://www.mrexcel.com/forum/excel-...bedded-worksheet-into-folder.html#post4464638

 

[RickXL]

Thanks, Jaafar, I'll take a look.

I did have problems using Object.Copy and I also had problems with DateCreated. However, if you use Object.Duplicate it always seems to put a copy in TEMP and using DateLastModified appears to overcome the the problem that previous versions of the file still seem to exist (with the original date) even though the name is not visible in the folder.

Regards,