|
|
楼主 |
发表于 2009-2-22 12:22
|
显示全部楼层
具体代码：
Option Explicit
Private Declare Sub GlobalUnlock Lib "kernel32" (ByVal hMem As Long)
Private Declare Sub CloseClipboard Lib "user32" ()
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, ByVal Source As Long, ByVal Length As Long)
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Sub DoIt()
GetPackFile Sheet1.OLEObjects(1), "C:\1.xls"
End Sub
'其中obj为要导出文件的包对象，FileName为输出文件名
Private Function GetPackFile(obj As OLEObject, FileName As String) As Boolean
GetPackFile = False
If obj Is Nothing Then Exit Function
If obj.progID <> "Package" Then Exit Function
Dim HandleC As Long, pMem As Long, FileSize As Long, fn As Long, i As Long, b As Byte
On Error Resume Next
Kill FileName
obj.Copy
If OpenClipboard(0) Then
HandleC = GetClipboardData(RegisterClipboardFormat("Native" & Chr$(0)))
If HandleC Then
pMem = GlobalLock(HandleC)
If pMem Then
If GetBytes(pMem, 2) = 0 Then
pMem = pMem + 6
Do While GetBytes(pMem, 1) <> 0: Loop
FileSize = GetBytes(pMem, 4)
fn = FreeFile
Err = 0
Open FileName For Binary Lock Write As fn
If Err = 0 Then
For i = 1 To FileSize
b = GetBytes(pMem, 1)
Put fn, , b
Next
Close fn
GetPackFile = True
End If
Else
MsgBox "包对象内不能有图标和标签名称，即左边内容应该全部为空, 而右边必须包含一个文件"
End If
End If
GlobalUnlock HandleC
End If
CloseClipboard
End If
End Function
Private Function GetBytes(ByRef pMem As Long, ByVal n As Integer) As Long
GetBytes = 0
CopyMemory GetBytes, ByVal pMem, n
pMem = pMem + n
End Function |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-2-22 12:08
