巧用剪切板导出包对象内的文件

ljw990485

本人做了一个系统，由多个含宏代码的工作薄组成，为了防止一些工作薄被用户删除，需要主工作薄内的代码能重建被删除的工作薄和其他文件（如Word文件），我使用了直接插入Excel工作薄和Word文档的方法，发现重新建立其它文件时，使用OleObject,Object,Save或SaveAS的方法，有时工作正常，有时不正常，甚至引发Excel程序崩溃；另外这样插入对象，会导致主工作薄体积庞大。
    于是我就想到使用包对象来保存压缩后的其它文件，但代码取不到包对象OleObject,Object，就更谈不上使用OleObject,Object,Save或SaveAS的方法保存包对象内的文件了，搜索本BBS内的帖子，找不到相关帖子，经过一晚上的翻查，终于找到某版主的一个帖子，现在忘记在哪了，代码大概意思是：
1）先用OleObject.verb  xlVerbOpen打开包对象，
2）再对包对象程序Sendkeys，相当于执行包对象程序的菜单，然后关闭包对象程序
  作者本人对该程序也不太满意

在一次偶然的机会，我手动复制包对象，然后在资源管理器内粘帖，竟然能导出包对象的文件，于是写了一篇帖子
VBA巧妙使用资源管理器导出包对象的文件
http://club.excelhome.net/thread-395416-1-1.html
帖子内的方法是：
1）OleObject,Copy复制包对象到剪切板
2）程序使用Shell Explorer打开一个资源管理器，且到指定的目录
3）程序使用Sendkeys发按键Ctrl+V到资源管理器，使得资源管理器执行粘帖动作

以上方法也存在很大的毛病，依赖Explorer进程，并且程序执行期间，可能会受到用户键盘和鼠标操作影响，如用户按键或鼠标点击或其它程序，都可以使得Explorer进程不在前台，导致粘帖失败。所以这种方法也不好。

现在大家看到了希望了吧，呵呵，竟然资源管理器能粘帖，说明文件已经在剪切板内了，下面的事情就是分析剪切板的内容，经过分析，在包对象被复制后，剪切板内竟然有16种不同格式的东西，哪资源管理器究竟使用哪种格式执行粘帖呢？
   经过对比，发现是Native格式，但这个格式下的内容除了包含所导入的文件以外，还在前面包含很多比较复杂的信息，里面有包对象的标签名，所导入的文件全路径文件名以及该包含路径文件名字符串长度，文件长度等，有些信息到现在我还不明白什么意思，嘻嘻。
   剩下的事情就比较简单了，代码写好就OK，具体大家见附件吧，这种方法就完全克服了以上二种方法依赖使用SendKeys对外部程序操作带来的无序性。包对象内的文件是本BBS的那个收音机，我稍微改了一下。

    我所做的系统的包对象包含的是其它文件的压缩文件，至于怎么解压包对象内导出的，本人先是使用网络上广泛流传的方法：
1）先查找注册表找到WinRar的安装目录
2）使用Shell执行WinRar对包对象导出的压缩文件解压
   但本人发现这样的方法一样存在很大的问题，在一些能正常使用WinRar的计算机上竟然在注册表找不到WinRar的安装目录！此方法很依赖外部程序，加上Shell是异步执行方式，导致我们无法估计WinRar何时完成解压任务

   经过在网络上搜索，至于找到了一位俄罗斯人用VB写的压缩解压程序，虽然压缩率比WinRar低一点点，解压速度也没那么快，但它能保证程序在任何时候是已知状态，是可预测的。
   我的具体做法是：
   1）本人使用这个程序压缩其它文件，且分别导入几个包对象中，导入前，压缩后的文件文件名越短越好，并且考入一个驱动器的根目录下，且去掉包对象左边的图标和标签，这样就能保证包对象复制时，剪切板内多余的信息最少；
   2）把俄罗斯人写的程序改造，去掉压缩部分的程序，并且直接从内存中解压包对象内的文件，还原解压后的文件

这个就不发出来了吧，嘻嘻

ljw990485

具体代码：
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

johnny05

good material

ljw990485

自己顶一下，哈哈，领导都不来呀

[ 本帖最后由 ljw990485 于 2009-2-22 17:16 编辑 ]

winland

这个帖子中49楼我也做了一个用剪贴板导出图片文件的例子。应该来说代码类似。。。
http://club.excelhome.net/viewthread.php?tid=341278&page=5

小fisher

http://www.officefans.net/cdb/viewthread.php?tid=58150
这里有更早的：）
Native格式前面的头其实并不复杂，如果嵌入的不是bmp, txt ,wav之类的通用格式或doc,xls之类的复合文档，通常会是这样的：
前两个字节00 20固定不变，之后是嵌入文件的文件名（不含路径），以00标记结束，然后是嵌入文件的短文件名，以00标记结束，之后是固定不变的四个字节00 00 03 00，之后四个字节是一个长整型数字，表明文件完整路径的字节长度，同时也表示嵌入文件的原始字节开始的位置，然后就是嵌入文件的完整路径，以00标记结束，紧跟着就是嵌入文件的原始字节长度和原始字节，最后以00 00作为嵌入文件的结尾

[ 本帖最后由 小fisher 于 2009-5-2 12:58 编辑 ]

小fisher

这是我的代码：
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long

Public Sub Export(targetFile As String, objOLE As OLEObject)
    Dim hMem As Long
    Dim nClipsize As Long
    Dim lpData As Long
    Dim bytData() As Byte
    objOLE.Copy
    OpenClipboard 0&
    hMem = GetClipboardData(49156)
    If CBool(hMem) Then
        nClipsize = GlobalSize(hMem)
        lpData = GlobalLock(hMem)
        If lpData <> 0 Then
            ReDim bytData(0 To nClipsize) As Byte
            CopyMemory bytData(0), ByVal lpData, nClipsize
        End If
        GlobalUnlock hMem
    End If
    EmptyClipboard
    CloseClipboard
   

    Dim iPos As Long
    Dim iCountZero As Integer
    Dim lOffset As Long
    Dim lFilesize As Long
    For iPos = 0 To nClipsize
        If bytData(iPos) = 0 Then
            iCountZero = iCountZero + 1
            If iCountZero = 3 Then Exit For
        End If
    Next
    iPos = iPos + 5
    CopyMemory lOffset, bytData(iPos), 4
    iPos = iPos + lOffset + 4
    CopyMemory lFilesize, bytData(iPos), 4
    iPos = iPos + 4
    CopyMemory bytData(0), bytData(iPos), lFilesize
    ReDim Preserve bytData(0 To lFilesize) As Byte

    Dim fileNumber As Integer
    fileNumber = freefile
    Open targetFile For Binary As #fileNumber
        Put #fileNumber, , bytData
    Close #fileNumber
End Sub

ljw990485

原帖由 小fisher 于 2009-5-2 12:55 发表
http://www.officefans.net/cdb/viewthread.php?tid=58150
这里有更早的：）
Native格式前面的头其实并不复杂，如果嵌入的不是bmp, txt ,wav之类的通用格式或doc,xls之类的复合文档，通常会是这样的：
前两个字节 ...

错误百出，呵呵，哈哈
前两个字节00 20固定不变

你肯定？还很多问题，你根本没研究透

其次，我讨论的问题是包对象，你原来的帖讨论的是GIF等文件，根本不是一回事
我都做出了含压缩文件的包对象自己代码自动解压

感觉你好象话中有话，你想表达什么呢？

[ 本帖最后由 ljw990485 于 2009-5-2 17:37 编辑 ]

小fisher

楼主的火药味很浓啊，好吧，我解释一下，我说的“这里有更早的”是和我楼上的Winland说的
我承认我没有研究透，我原来帖子中的GIF等文件是指以“插入－对象”命令嵌入在Excel工作簿中的除bmp, txt, wav和复合文档之外的其他文件，当使用复制命令后，它们在剪贴板中以Native格式存在的字节是有规律的，据我观察还没有发现例外，当然仍然可能存在这样的例外，所以我说“通常”，如果你能找到不符合的，请举出来。“前两个字节00 20固定不变”这句是手误，应该是02 00
你说的包对象和我说的嵌入文件应该是一回事
我不知道哪句话冒犯到你了，希望你能心平气和地讨论

ljw990485

原帖由 小fisher 于 2009-5-2 20:50 发表
楼主的火药味很浓啊，好吧，我解释一下，我说的“这里有更早的”是和我楼上的Winland说的
我承认我没有研究透，我原来帖子中的GIF等文件是指以“插入－对象”命令嵌入在Excel工作簿中的除bmp, txt, wav和复合文档之 ...

引用Linux之父Linus Torvalds说的话：去看代码