Solved: Playing Embedded Wav File

[Paul_Hossler]

Vista / Win7 and Office 2007/2010

Playing a Wav file that is on the disc is easy, but I'd like to 'package' the wav's with the XLSM by embedding them on a worksheet and executing them under VBA control

If if use .Verb

[VBA]
Sub drv()
Call Worksheets("Media").OLEObjects("SorryDave").Verb(xlPrimary)
End Sub
[/VBA]

if does play but there's a prompt before WMP starts, WMP is in a visible window, and then WMP doesn't close after it finishs

Any ideas? It seems like it should be easy, but even Google was no help

Paul

[Kenneth Hobs]

Save the object to a file in the temp folder. http://www.officekb.com/Uwe/Forum.as...e-to-hard-disk

Then use API such as, sndPlaySound32, to play it.

[Paul_Hossler]

Thanks, I had found that googling around, but GetData seems to fail

[vba]
' Get memory handle to the data
hWnd = GetClipboardData(Format)
[/vba]

with hWnd = 0

Format = 49156 (= Native format)

I seem to recall that in VBA the only supported clipboard formats are string and numbers

Paul

[Kenneth Hobs]

This works for me.

[VBA]Option Explicit

' Predefined Clipboard Formats
Public Const CF_TEXT = 1
Public Const CF_BITMAP = 2
Public Const CF_METAFILEPICT = 3
Public Const CF_SYLK = 4
Public Const CF_DIF = 5
Public Const CF_TIFF = 6
Public Const CF_OEMTEXT = 7
Public Const CF_DIB = 8
Public Const CF_PALETTE = 9
Public Const CF_PENDATA = 10
Public Const CF_RIFF = 11
Public Const CF_WAVE = 12
Public Const CF_UNICODETEXT = 13
Public Const CF_ENHMETAFILE = 14

Public Const CF_OWNERDISPLAY = &H80
Public Const CF_DSPTEXT = &H81
Public Const CF_DSPBITMAP = &H82
Public Const CF_DSPMETAFILEPICT = &H83
Public Const CF_DSPENHMETAFILE = &H8E

' "Private" formats don't get GlobalFree()'d
Public Const CF_PRIVATEFIRST = &H200
Public Const CF_PRIVATELAST = &H2FF

'Michel Pierron
'http://www.officekb.com/Uwe/Forum.aspx/excel-prog/97891/Saving-embedded-OLE-object-as-file-to-hard-disk

Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hWnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function _
GlobalSize& Lib "kernel32" (ByVal hMem&)
Private Declare Function _
GlobalLock& Lib "kernel32" (ByVal hMem&)
Private Declare Function _
GlobalUnlock& Lib "kernel32" (ByVal hMem&)
Private Declare Sub CopyMem Lib "kernel32" Alias _
"RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length&)

Private Function GetData(ByVal Format&, abData() As Byte) As Boolean
Dim hWnd&, Size&, Ptr&
If OpenClipboard(0&) Then
' Get memory handle to the data
hWnd = GetClipboardData(Format)
' Get size of this memory block
If hWnd Then Size = GlobalSize(hWnd)
' Get pointer to the locked memory
If Size Then Ptr = GlobalLock(hWnd)
If Ptr Then
' Resize the byte array to hold the data
ReDim abData(0 To Size - 1) As Byte
' Copy from the pointer into the array
CopyMem abData(0), ByVal Ptr, Size
' Unlock the memory
Call GlobalUnlock(hWnd)
GetData = True
End If
EmptyClipboard
CloseClipboard
DoEvents
End If
End Function

Sub Test_SaveWAVOLEAs()
SaveWAVOLEAs Sheet2.OLEObjects("YesMaster"), "x:\t\yesmaster.wav"
End Sub


Sub SaveWAVOLEAs(oOLE As oleObject, fnOLE As String)
Dim B() As Byte, F As Integer, tf As Boolean
oOLE.Copy
tf = GetData(49156, B)
'If Not GetData(49156, B) Then Exit Sub
'If Not GetData(CF_WAVE, B) Then Exit Sub
If Len(Dir(fnOLE)) Then Kill fnOLE
F = FreeFile
Open fnOLE For Binary As #F
Put #F, , B
Close #F
End Sub

Sub SaveEmbeddedFile()
Dim Sh As Shape, B() As Byte, Pos&, F&
For Each Sh In ActiveSheet.Shapes
If InStr(1, Sh.Name, "Object", 1) Then
Sh.Copy ' (49156 = Native format)
If Not GetData(49156, B) Then Exit Sub
Dim Buffer$, FileName$, Extension$
Buffer = StrConv(B, vbUnicode)
FileName = "Embedded"
Extension = ".emb"
Pos = InStr(3, Buffer, ".", 1)
If Pos Then
FileName = Mid$(Buffer, 3, Pos - 3)
Extension = Mid$(Buffer, Pos, 4)
End If
FileName = "c:\" & FileName & Extension
If Len(Dir(FileName)) Then Kill FileName
F = FreeFile
Open FileName For Binary As #F
Put #F, , B
Close #F
End If
Next Sh
End Sub


[/VBA]

[Paul_Hossler]

Mr. Kenneth "OLE" Hobs --

Thanks again. Your code extracted the OLE file nicely.

I can't play the extracted file I generate because it looks like there's some OLE header-type information, but I think I was able to sort it out

The signature for the original Wave file has RIFF at the start.

The output file has what looks like OLE information at the beginning and RIFF starts 350 bytes into the file,but that would vary based on filename lengths, etc.

I don't know if this is the best way, it does seem to allow the extracted file to work with the sndPlaySound32 API, so life is good

[vba]
Sub SaveWAVOLEAs(oOLE As OLEObject, fnOLE As String)

Const iAscR As Byte = 82
Const iAscI As Byte = 73
Const iAscF As Byte = 70


Dim iRIFF As Long, iByte As Long
Dim abData() As Byte, iFileNum As Long, bResult As Boolean

oOLE.Copy
bResult = GetData(49156, abData)

iRIFF = 0
Do While Not (abData(iRIFF) = iAscR And abData(iRIFF + 1) = iAscI And abData(iRIFF + 2) = iAscF And abData(iRIFF + 3) = iAscF)
iRIFF = iRIFF + 1
Loop


If Len(Dir(fnOLE)) Then Kill fnOLE

iFileNum = FreeFile
Open fnOLE For Binary As #iFileNum

For iByte = iRIFF To UBound(abData)
Put #iFileNum, , abData(iByte)
Next iByte
Close #iFileNum
End Sub
[/vba]

I would hope that there's a more robust way to find out where the real data starts for other kinds of files when they're embedded

Thanks, and I will take any more suggestions

Paul