Pasting embedded OLE objects to specific filename

[atvaluesoftware]

The following code copies an embedded OLE object and pastes it to the
specified path:

Sub Test()
ActiveSheet.OLEObjects("Object 1").Copy

'paste to activeworkbook's path
CreateObject("Shell.Application") _
.Namespace(ActiveWorkbook.Path) _
.Self.InvokeVerb "Paste"
End Sub

What about pasting the object and giving it a particular filename
during the paste action? With the code given, the object is pasted
correctly. However, by default, the filename used in the pasting is the
filename that was specified during the Insert > Object > Create from
File process (initial insert of the object).

Is there anyway to change the filename used in the paste?

 

[Tim Williams]

Run a Dir() on the folder first, then check which is the new file
following the paste, then rename it....

Tim.

 

[okaizawa]

I don't know how to name the file while pasting.
but after pasted, it can be renamed. for example,

Sub test2()
Dim FileName As String
Dim TempPath As String
Dim TempFile As String

On Error GoTo ErrorHandler

If ActiveWorkbook.Path = "" Then Exit Sub
FileName = ActiveWorkbook.Path & "\My.mdb"
TempPath = ActiveWorkbook.Path & "\TMP"

If Dir(FileName) <> "" Then
MsgBox "'" & FileName & "' already exists."
Exit Sub
End If

If Dir(TempPath, vbDirectory) = "" Then MkDir TempPath

If Dir(TempPath & "\") <> "" Then
MsgBox "Remove all files in '" & TempPath & "', then try again."
Exit Sub
End If

'copy an oleobject
ActiveSheet.OLEObjects("Object 1").Copy

'paste to a temp-folder
CreateObject("Shell.Application") _
.NameSpace(CVar(TempPath)).Self.InvokeVerb "Paste"

'get the filename
TempFile = Dir(TempPath & "\")
If TempFile = "" Then
MsgBox "No file."
Exit Sub
End If

'move and rename the file
Name TempPath & "\" & TempFile As FileName

'TempPath seems to be locked while procedures are running.
'the below might not be able to remove it.
On Error Resume Next
Kill TempPath & "\*"
RmDir TempPath

Exit Sub

ErrorHandler:
MsgBox Err.Description, vbExclamation
Exit Sub

End Sub