Possible to Copy a .wav file embedded in a worksheet into a folder?

[MPW]

Hi All,

I have been using Excel to create the recording files and file structure for new projects for over 10 years.
The only handicap to this process is that the blank Template.wav file that I use for this was required to exist in a certain folder.

I would like to know if I embed the audio file into a worksheet, is it possible to copy and then paste it into a folder using VBA?

 

[MPW]

Someone suggested using this method of embedding the file.

Sub EmbedWav()'
' Embed a wav file into a worksheet
'
' This code is only needed for loading a worksheet
'
    Dim Bytes() As Byte
    Dim FileNum As Integer
'
' Path and Filename of Wav file to read in goes here:
    Const Wav_Path_Name As String = "C:\Temp\tmpFile.Wav"
'
' Get available file number
    FileNum = FreeFile
'
' Adjust Byte array to the size of the file
    ReDim Bytes(1 To FileLen(Wav_Path_Name))
'
' Read file in binary
    Open Wav_Path_Name For Binary As #FileNum
        Get #FileNum, 1, Bytes
    Close FileNum
'
' Write binary info to a worksheet (could be hidden)
    With Worksheets("Wav_Bytes")
        .Range(.Cells(1, 1), .Cells(UBound(Bytes), 1)).Value = Application.Transpose(Bytes)
    End With
'
' Save Changes
    ThisWorkbook.Save
'
End Sub

However I ran across a Type Mis-Match on this part.

    With Worksheets("Wav_Bytes")
        .Range(.Cells(1, 1), .Cells(UBound(Bytes), 1)).Value = Application.Transpose(Bytes)
    End With

I have never worked with anything like this before. Any Ideas?

 

[Jaafar Tribak]

Hi,

I would like to know if I embed the audio file into a worksheet, is it possible to copy and then paste it into a folder using <acronym title="visual basic for applications" style="border-width: 0px 0px 1px; border-bottom-style: dotted; border-bottom-color: rgb(0, 0, 0); cursor: help; color: rgb(51, 51, 51); background-color: rgb(250, 250, 250);">VBA</acronym>?

You could copy the worksheet embedded wav file to the clipboard and then paste the clipboard content into a folder using the Shell Namespace Method

The SaveEmbeddedOleObjectToDisk function below takes an embedded oleobject in its first argument and the destination PathName of the file in its second argument:

Put the following code in a standard module and run the Test example Macro where 'Object 1' is the name of the embedded WAV oleobject and 'C:\test\WAV_1.wav' is the file destination path and name ( Change these as needed)

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
#Else
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
#End If
 
Private Type FUNC_OUT_RESULTS
    SUCCESS As Boolean
    SAVED_FILE_PATH_NAME As String
    ERROR As String
End Type




Sub TEST()
    Dim tRes As FUNC_OUT_RESULTS
    Dim oleObj As OLEObject
    
    tRes = SaveEmbeddedOleObjectToDisk _
    (EmbeddedObject:=ActiveSheet.OLEObjects("Object 1"), FilePathName:="C:\test\WAV_1.wav")
    
    With tRes
        If .SUCCESS Then
            MsgBox "OleObject successfully saved as : '" & .SAVED_FILE_PATH_NAME & " '", vbInformation
        Else
            MsgBox .ERROR, vbCritical
        End If
    End With


End Sub


Private Function SaveEmbeddedOleObjectToDisk( _
    ByVal EmbeddedObject As OLEObject, _
    ByVal FilePathName As String _
    ) _
    As FUNC_OUT_RESULTS


    Dim oFolder As Object
    Dim sFolder As String
    
    On Error GoTo errHandler
    If Len(Dir$(FilePathName)) <> 0 Then Err.Raise 58
    sFolder = Left$(FilePathName, InStrRev(FilePathName, "\") - 1)
    If Len(Dir$(sFolder, vbDirectory)) = 0 Then
        MkDir sFolder
    End If
    If EmbeddedObject.OLEType = xlOLEEmbed Then
        EmbeddedObject.Copy
        Set oFolder = CreateObject("Shell.Application").Namespace(sFolder & Chr(0))
        oFolder.Self.InvokeVerb "Paste"
        Name GetPastedFile(sFolder) As FilePathName
        SaveEmbeddedOleObjectToDisk.SAVED_FILE_PATH_NAME = FilePathName
        SaveEmbeddedOleObjectToDisk.SUCCESS = True
    End If
    Call CleanClipBoard
    Exit Function
errHandler:
            SaveEmbeddedOleObjectToDisk.ERROR = Err.Description
    Call CleanClipBoard
End Function




Private Function GetPastedFile( _
    ByVal Folder As String _
    ) _
    As String
    
    Dim sCurFile As String
    Dim sNewestFile As String
    Dim dCurDate As Date
    Dim dNewestDate As Date
    
    Folder = Folder & "\"
    sCurFile = Dir$(Folder & "*.*", vbNormal)
    Do While Len(sCurFile) > 0
        dCurDate = FileDateTime(Folder & sCurFile)
        If dCurDate > dNewestDate Then
            dNewestDate = dCurDate
            sNewestFile = Folder & sCurFile
        End If
        sCurFile = Dir$()
    Loop
    GetPastedFile = sNewestFile
End Function


Private Sub CleanClipBoard()
    OpenClipboard 0
    EmptyClipboard
    CloseClipboard
End Sub