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" a écrit dans le
message de news:
...
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 he
http://forums.microsoft.com/MSDN/Sho...56587&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.
--
Tonioant
"Michel Pierron" wrote:
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" a écrit dans
le
message de news: ...
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
--
Tonioant