VB6 Excel VBA 如何复制文件到剪贴板 的一个Bug修复 （用Windows API 来将文件/文件夹复制到剪贴板的源代码 )

在开发 文档大师 PinPKM 个人知识库管理专业软件时，需要提供将知识库的文件复制到Windows剪贴板的功能，

网上找到一段代码，测试发现存在一个Bug，应该是对Unicode不了解造成的，

即计算字符长度，对VB而言，长度是1，对于Unicode可能是2~6字节，一般不超过3字节。

修正后，目前测试能正常复制大量文件，而不会出错。

   dataLen = Len(Data) * 3
        
 hGlobal = GlobalAlloc(GHND, Len(df) + dataLen + 15)
'   hGlobal = GlobalAlloc(GHND, Len(df) + Len(Data) + 15)

https://club.excelhome.net/thread-1569882-1-1.html?_dsign=9c297480

Option Explicit


'剪贴版处理函数
Private Declare Function EmptyClipboard Lib "user32" () 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 SetClipboardData Lib "user32" (ByVal wFormat _
        As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat _
        As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32" _
        (ByVal wFormat As Long) As Long
Private Declare Function DragQueryFile Lib "shell32.dll" Alias _
        "DragQueryFileA" (ByVal hDrop As Long, ByVal UINT As Long, _
        ByVal lpStr As String, ByVal ch As Long) As Long
Private Declare Function DragQueryPoint Lib "shell32.dll" (ByVal _
        hDrop As Long, lpPoint As POINTAPI) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags _
        As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As _
        Long) As Long
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 Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Any, Source As Any, ByVal Length As Long)
        
Private Declare Function SHFileOperation Lib "shell32.dll" Alias _
        "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
        
'剪贴版数据格式定义
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const CF_METAFILEPICT = 3
Private Const CF_SYLK = 4
Private Const CF_DIF = 5
Private Const CF_TIFF = 6
Private Const CF_OEMTEXT = 7
Private Const CF_DIB = 8
Private Const CF_PALETTE = 9
Private Const CF_PENDATA = 10
Private Const CF_RIFF = 11
Private Const CF_WAVE = 12
Private Const CF_UNICODETEXT = 13
Private Const CF_ENHMETAFILE = 14
Private Const CF_HDROP = 15
Private Const CF_LOCALE = 16
Private Const CF_MAX = 17
' 内存操作定义
Private Const GMEM_FIXED = &H0
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_NOCOMPACT = &H10
Private Const GMEM_NODISCARD = &H20
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MODIFY = &H80
Private Const GMEM_DISCARDABLE = &H100
Private Const GMEM_NOT_BANKED = &H1000
Private Const GMEM_SHARE = &H2000
Private Const GMEM_DDESHARE = &H2000
Private Const GMEM_NOTIFY = &H4000
Private Const GMEM_LOWER = GMEM_NOT_BANKED
Private Const GMEM_VALID_FLAGS = &H7F72
Private Const GMEM_INVALID_HANDLE = &H8000
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Const FO_COPY = &H2
Private Type POINTAPI
   X As Long
   y As Long
End Type
Private Type DROPFILES
   pFiles As Long
   pt As POINTAPI
   fNC As Long
   fWide As Long
End Type
Private Type SHFILEOPSTRUCT
    hWnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAnyOperationsAborted As Long
    hNameMappings As Long
    lpszProgressTitle As String
End Type
Public Function clipCopyFiles2022(Files() As String) As Boolean ' 函数入口
Dim Data As String
Dim df As DROPFILES
Dim hGlobal As Long
Dim lpGlobal As Long
Dim i As Long
Dim isOpenClipboard As Boolean
Dim dataLen As Integer
On Error GoTo subErr
isOpenClipboard = False

'Print '清除剪贴版中现存的数据
    If OpenClipboard(0&) Then
        isOpenClipboard = True
        Call EmptyClipboard
        '把文件名数组中的各项目放入Data字符串中, 注意在各项目后+VBNULLCHAR
        Data = ""
        For i = LBound(Files) To UBound(Files)
            Data = Data & Files(i) & vbNullChar
        Next i
             '最后再额外+一个VBNULLCHAR
        Data = Data & vbNullChar
        '为剪贴版拷贝操作分配相应大小的内存
        
        dataLen = Len(Data) * 3
        
        hGlobal = GlobalAlloc(GHND, Len(df) + dataLen + 15)
'             hGlobal = GlobalAlloc(GHND, Len(df) + Len(Data) + 15)
        
             '重点来了, 注意这里的+15, 以下还有一个位置同理如下:
             '如果没有这个+15
             '会出现一些无法复制到剪贴板的问题
             '这个问题也是我遇到困难的根本! 最后灵光一现想到的
        
             '在win7中win10中均存在, 但是在win10中犹为明显
             '从操作理解层面, 个人理解是win10设了一些额外信息/门槛, 供参考
             '由于多设了信息/门槛, 而这些也占了位置,
        
             '所以我们要放入内存中相应扩大位置来容纳, 以免由于位置不够
             '导致路径字符串无法正常进入剪贴板
        
             '这里值得思考的是, winodws还是那个windows
             '不是说从32位到64位或是从win7到win10就发生根本变化
             '可能多了包装, 改了门面, 多了防护, 加了门槛, 换了新装
        
             '但请记得这些API都是底层的钢筋混凝柱, 根本未变
             '更值得我们依赖的
        
             '现在很多时候我们依赖现有的比如clipboard对象
             '没错, 是被封装起来, 方便程序员使用的. 比如一些文件或图形的复制粘贴
        
             '而这些对象内部其实就是丰富的API组成的
             '为了大部分程序员方便使用而固定下来的一套集合
        
             '然而当我们需要特别或更高级能力时, 这些对象可能不能直接满足我们
             '我们依然需要面向过程, 去找到各种零件来支撑我们需要的功能模块
             '可能会很累很苦, 但是能提升境界与能力.
        
        If hGlobal Then
            lpGlobal = GlobalLock(hGlobal)
            
            df.pFiles = Len(df)
            '将DropFiles结构拷贝到内存中
            Call CopyMem(ByVal lpGlobal, df, Len(df))
            '将文件全路径名拷贝到分配的内存中
            Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal Data, dataLen + 15)
'           Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal Data, Len(Data) + 15)
                '注意这里的+15, 同上所述
            Call GlobalUnlock(hGlobal)
            
            '将数据拷贝到剪贴版上
            If SetClipboardData(CF_HDROP, hGlobal) Then
                clipCopyFiles2022 = True
            End If
        End If
        Call CloseClipboard
        isOpenClipboard = False
        
    End If
    Exit Function
'**************************
subErr:
If isOpenClipboard Then
            Call CloseClipboard
End If
    Dim mycErrorProcess As cErrorProcess
'    Screen.MousePointer = MousePointerConstants.vbDefault
    Set mycErrorProcess = New cErrorProcess
   mycErrorProcess.Message = Err.Description
    Set mycErrorProcess = Nothing
End Function
'Public Function clipCopyFiles2(Files() As String) As Boolean '此功能不稳定, 有些项目无法进行复制到剪切板
'   Dim Data As String
'   Dim df As DROPFILES
'   Dim hGlobal As Long
'   Dim lpGlobal As Long
'   Dim i As Long
'
'   '清除剪贴版中现存的数据
'   If OpenClipboard(0&) Then
'        Call EmptyClipboard
'
'        For i = LBound(Files) To UBound(Files)
'            Data = Data & Files(i) & vbNullChar
'        Next i
'        Data = Data & vbNullChar
'        '为剪贴版拷贝操作分配相应大小的内存
'        hGlobal = GlobalAlloc(GHND, Len(df) + Len(Data) + 15)
'        If hGlobal Then
'            lpGlobal = GlobalLock(hGlobal)
'
'            df.pFiles = Len(df)
'     '将DropFiles结构拷贝到内存中
'            Call CopyMem(ByVal lpGlobal, df, Len(df))
'     '将文件全路径名拷贝到分配的内存中
'            Call CopyMem(ByVal (lpGlobal + Len(df)), ByVal Data, _
'                Len(Data) + 15)
'            Call GlobalUnlock(hGlobal)
'
'            '将数据拷贝到剪贴版上
'            If SetClipboardData(CF_HDROP, hGlobal) Then
'                clipCopyFiles = True
'            End If
'        End If
'        Call CloseClipboard
'    End If
'End Function

'Sub test()
'Dim aF(0 To 3) As String
'Dim af2() As String
''在win7下, 除了少数如*.wri文件与偶尔有个xlsm(怀疑是5M太大了)不能复制
''其它都可以顺利进入剪贴板而后被win系统右键粘贴
'
''在win10下, 事情变得离奇, EXE与文件夹成功复制粘贴的机率较高, 但也有不成功
''同一个文件夹在不同的位置时也影响成功与否.
'aF(0) = ThisWorkbook.path & "\Test\EXEFILE.EXE"
'aF(1) = ThisWorkbook.path & "\Test\zipFILE.zip"
'
'aF(2) = ThisWorkbook.path & "\Test\xlsxfile.xlsx"
'aF(3) = ThisWorkbook.path & "\Test\xlsmfile.xlsm"
''
''aF(0) = ThisWorkbook.Path & "\Test\xlsfile.xls"
''aF(0) = ThisWorkbook.Path & "\Test\Folder"
''aF(0) = ThisWorkbook.Path & "\Test\txtfile.txt"
''aF(0) = ThisWorkbook.Path & "\Test\rarFILE.rar"
'Debug.Print (clipCopyFiles(aF))
'Beep
'
''Debug.Print (clipPasteFiles(af2))
'
'End Sub


'*****以下为取出操作*****

Public Function clipPasteFiles(Files() As String) As Long

   Dim hDrop As Long
   Dim nFiles As Long
   Dim i As Long
   Dim desc As String
   Dim filename As String
   Dim pt As POINTAPI
   Dim tfStr As SHFILEOPSTRUCT
   Const MAX_PATH As Long = 260

   '确定剪贴版的数据格式是文件，并打开剪贴版
   If IsClipboardFormatAvailable(CF_HDROP) Then
        If OpenClipboard(0&) Then
            hDrop = GetClipboardData(CF_HDROP)
            '获得文件数
            nFiles = DragQueryFile(hDrop, -1&, "", 0)
      
            ReDim Files(0 To nFiles - 1) As String
            filename = Space(MAX_PATH)
         
            '确定执行的操作类型为拷贝操作
            tfStr.wFunc = FO_COPY
            '目的路径设置为File1指定的路径
            tfStr.pTo = "d:\test\234\" 'Form1.File1.Path
         
            For i = 0 To nFiles - 1
            '根据获取的每一个文件执行文件拷贝操作
                Call DragQueryFile(hDrop, i, filename, Len(filename))
                Files(i) = TrimNull(filename)
                tfStr.pFrom = Files(i)
                SHFileOperation tfStr
            Next i
            'Form1.File1.Refresh
            'Form1.Dir1.Refresh
         
            Call CloseClipboard
        End If
        clipPasteFiles = nFiles
    End If
End Function
Private Function TrimNull(ByVal StrIn As String) As String
   Dim nul As Long
   
   nul = InStr(StrIn, vbNullChar)
   Select Case nul
      Case Is > 1
         TrimNull = left(StrIn, nul - 1)
      Case 1
         TrimNull = ""
      Case 0
         TrimNull = Trim(StrIn)
   End Select
End Function

Sub TEST1()
Dim X() As String
TESTAA X
End Sub

Function TESTAA(X() As String)
ReDim X(1 To 2) As String
End Function