| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Saving embedded OLE object as file to hard disk
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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Saving embedded OLE object as file to hard disk
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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Saving embedded OLE object as file to hard disk
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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Saving embedded OLE object as file to hard disk
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 -- Tonioant "Michel Pierron" wrote: 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 |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Saving embedded OLE object as file to hard disk
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. "Anton Rapoport" wrote: 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 -- Tonioant "Michel Pierron" wrote: 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 |
|
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Saving embedded OLE object as file to hard disk
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 "NoDozing" a écrit dans le message de news: ... 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. "Anton Rapoport" wrote: 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 -- Tonioant "Michel Pierron" wrote: 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 |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Excel changes file extension on embedded object upon save | Excel Discussion (Misc queries) | |||
| I get a disk full message when saving large excel file. | Excel Discussion (Misc queries) | |||
| Money 2005's home pages' URL should le me access to my hard disk. | Excel Discussion (Misc queries) | |||
| PRINTING AUTOMATIQUE ON HARD DISK | New Users to Excel | |||
| Saving embedded object to disk | Excel Programming | |||
Linear Mode
