Saving embedded OLE object as file to hard disk

[Anton Rapoport]

Hello, Excel experts

I have faced the following problem (I will not be surprised if it cannot be
solved at all in Excel VBA):

Excel allows to embed an OLE object into a worsheet. Manually a user has to
click "Insert" from the main menu, then "Object", then choose the "Create
from file" tab and then select a file to embed. A user is free to embed any
(generic) file with any file extension, e.g. test.zip or test.tst or whatever
which may not be necessarily associated with a Windows application.

My problem is I need to save the embedded file back to a hard disk. Manually
the user has to right-click on the embedded file icon, then choose "Package
Object", then "Edit Package". After that a separate "Object Packager" window
will appear. There in the "Object pckager" window the user clicks "File" and
"Save contents" to save the embedded file as a file back to a user-selected
location.
But how to do it from VBA code? How can I save a file embedded as object
into the sheet back to hard disk?

Thanks a lot for your help in advance,

Anton

 

[Michel Pierron]

Hi Anton,
be careful with this code (only tested with zip and txt), but you can try:

In a standard module:
Option Explicit
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 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

Regards,
MP

 

[Anton Rapoport]

Michel, thank you very much for the advice and the code.

You have actually surprised me very much. I came to the same approach some
time ago - I also copied the embedded OLE object into windows clipboard, and
then retrieved it via "Native" format. Then I had to cut the actual file
content from the "Native" format data. This was the only way I could save the
embedded file to disk. But I was not satisfied with the approach - it is not
logical to send file to clipboard and then back, the file size may be big and
"additional clipboard layer" in data flow may reduce the performance greatly
or even block the functionality. Secondly, there is a chance that the user
will also use the clipboard in parallel - so user's concurrent work with
clipboard may destroy the program operation and also the program operation
may destroy user's work if he is just using clipboard at the same time.
Please don't get me wrong: I am not criticizing the "clipboard aproach" - I
had same approach as you have suggested simply because I could not find more
"standard" way of getting embedded object without using clipboard. So I am
very grateful for your reply anyways.

If we could find s standard solution which just somehow takes the original
OLE object and persist it to a file, it would be much safer and more reliable.

Again thanks

Anton

P.S. My suggestions were described here:
http://forums.microsoft.com/MSDN/ShowPost.aspx?PostID=656587&SiteID=1
It does not matter for me which language/platform to use : VBA, .NET or even
Win32. It does not really matter. I am looking for a "proper approach" to
solve this problem - then it may be implemented in any language quickly.

 

[Michel Pierron]

Hi Anton,
If you prefer, here another possibility; it is not a super exercise of style
of programming, but it goes.

Option Explicit
Private Declare Function GetForegroundWindow& Lib "user32" ()
Private Declare Function GetWindowText Lib "user32" Alias _
"GetWindowTextA" (ByVal hWnd As Long _
, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetMenu& Lib "user32" (ByVal hWnd&)
Private Declare Function GetSubMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib "user32" _
(ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuString Lib "user32" Alias _
"GetMenuStringA" (ByVal hMenu As Long, ByVal wIDItem As Long _
, ByVal lpString As String, ByVal nMaxCount As Long _
, ByVal wFlag As Long) As Long
Private Declare Function GetMenuItemCount _
Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias _
"PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long _
, ByVal wParam As Long, ByVal lParam As Long) As Long

' Save zip embedded file example
Sub SaveEmbeddedObject()
If ActiveSheet.OLEObjects.Count = 0 Then Exit Sub
With ActiveSheet.OLEObjects(1)
If .progID = "Package" And .OLEType = 1 Then .Verb 2
End With
' To replace windows French titles by English version
Const Title1$ = "Gestionnaire de liaisons"
Const Title2$ = "Enregistrer le contenu"
Const FileName$ = "Embedded.zip"
Dim fPath$, hApp1&, hApp2&
hApp1 = WaitWindow(Title1)
If hApp1 Then
fPath = Application.DefaultFilePath & "\" & FileName
If Len(Dir(fPath)) Then Kill fPath
Call RunMenu(hApp1, Title2)
hApp2 = WaitWindow(Title2)
If hApp2 Then Application.SendKeys FileName & "~", -1
PostMessage hApp1, &H10, 0&, 0& ' (&H10 = WM_CLOSE)
End If
End Sub

Private Function WaitWindow(Info$, Optional Delay& = 5) As Long
Dim hWnd&, Start!: Start = Timer
Do
hWnd = GetForegroundWindow
If InStr(1, WindowText(hWnd), Info, 1) Then
WaitWindow = hWnd: Exit Function
End If
DoEvents
If (Timer - Start) > Delay Then Exit Function
Loop
End Function

Private Function WindowText(ByVal hWnd&) As String
Dim Buffer$: Buffer = String(100, Chr$(0))
GetWindowText hWnd, Buffer, 100
WindowText = Left$(Buffer, InStr(Buffer, Chr$(0)) - 1)
End Function

Private Sub RunMenu(ByVal hWnd&, Menu$)
Dim hSubMenu&, i&, m&, u&, Ret&, Buf$
Dim hMenu&: hMenu = GetMenu(hWnd)
For i = 0 To GetMenuItemCount(hMenu) - 1
hSubMenu = GetSubMenu(hMenu, i)
For m = 0 To GetMenuItemCount(hSubMenu) - 1
u = GetMenuItemID(hSubMenu, m)
Buf = String$(100, " ")
Ret = GetMenuString(hSubMenu, u, Buf, 100, 1)
If InStr(1, Left$(Buf, Len(Buf) - 1), Menu, 1) Then GoTo 1
Next m
Next i
Exit Sub
1: PostMessage hWnd, &H111, u, 0 ' (&H111 = WM_COMMAND)
End Sub

Regards,
MP

 

[Anton Rapoport]

Hello Michel,

Thanks for another suggestion You have surprised me with this approach
more than you did when described the "clipboard" solution. I know you have
offered an alternative solution now, but it is actually a mere win32
solutiuon which uses low level API for locating open windows and simulating
selecting menu items and clicking them to save the object content. It means
that this solution actually represents the end-user for Excel.
So I am grateful for another option from you, but to be honest ;-) I'd
rather stay with the "clipboard" solution in this case.

All the best to you and thanks for all your help,

Anton

 

[NoDozing]

The last suggestion could also have a timing issue. What if the delay isn't
long enough?

I've been fighting this issue for a couple of weeks (i.e. how to save an
embedded object to a file). I wish there were an easier interface, but
appreciate finding this solution. I also found the one over on VST forum.

 

[Michel Pierron]

Hi NoDozing,
By default, the delay is 5 seconds; but you can adjust this value as you
wish. If the delay is exceeded, the function returns 0; consequently, it
does not occur anything.
If you know the embedded file type, you can open the Excel file container in
binary mode and seek the corresponding heading there; if this heading is
found, you continue the iteration until finding the marker of end of file.
Then, you can to save the interval corresponding to the embedded file on the
disk.
Example for embedded zip file:

Sub SaveEmbeddedFile()
' Full path name of Excel file container
Const Wbk$ = "C:\Documents and Settings\Mezig\My documents\EmbeddedFile.xls"
' Folder where to save the file
Const sPath$ = "c:\"
MsgBox FindZipFile(Wbk, sPath), 64
End Sub

' (Length zip head structure = 30)
' (Length zip end structure = 22)
Private Function FindZipFile(sFile$, sFolder$) As String
Const Msg1$ = "File not found !"
Const Msg2$ = "Folder not found !"
Const Msg3$ = "Embedded zip file not found !"
Const Msg4$ = "Embedded zip file saved under name:"
If Dir(sFile) = "" Then FindZipFile = Msg1: Exit Function
If Not Right(sFolder, 1) = "\" Then sFolder = sFolder & "\"
If Dir(sFolder, 16) = "" Then FindZipFile = Msg2: Exit Function
Dim i&, Pos&, Chain$, u&: u = 1
Dim b() As Byte: ReDim b(0 To 1023)
On Error GoTo 1
' (head structure + end structure = 52)
Dim lFile&: lFile = FileLen(sFile) - 52
' Zip head marker value
Chain$ = Chr(80) & Chr(75) & Chr(3) & Chr(4)
Dim f&: f = FreeFile
Open sFile For Binary Access Read As #f
Do While u < lFile
Get #f, u, b
Pos = InStr(1, StrConv(b, vbUnicode), Chain, 1)
If Pos Then
i = Pos + u - 1
u = u + Pos + 4 ' (Length Chain = 4)
' Zip End marker value
Chain = Chr(80) & Chr(75) & Chr(5) & Chr(6)
Do While u < lFile
Get #f, u, b
Pos = InStr(1, StrConv(b, vbUnicode), Chain, 1)
If Pos Then Pos = Pos + u + 22 - 1: Exit Do
u = u + 1021 ' Covering margin if the chain is cut
Loop
Exit Do
End If
u = u + 1021 ' Covering margin if the chain is cut
Loop
If i = 0 Or Pos = 0 Then FindZipFile = Msg3: GoTo 1
ReDim b(0 To Pos - i - 1)
Get #f, i, b
Close #f
Pos = InStr(1, StrConv(b, vbUnicode), ".", 1)
Dim FileName$
FileName = Mid$(StrConv(b, vbUnicode), 31, Pos - 30)
FileName = sFolder & FileName & "zip"
' Save zip file on disk
If Dir(FileName) <> "" Then Kill FileName
f = FreeFile
Open FileName For Binary As #f
Put #f, , b
FindZipFile = Msg4 & vbLf & FileName & " !"
1: Close #f
If Err.Number = 0 Then Exit Function
FindZipFile = "Error: " & Err.Number & vbLf & Err.Description & " !"
End Function

Regards,
MP