VBA VB6 用Windows API 来将文件/文件夹复制到剪贴板 ( Win7 + Win10 )

ebkzxcel

< 前言, 着急可跳过 >

这个问题是是自己遇到的, 然后在网上找了好久好久也没有找到答案
在不断地搜索, 与困难博斗的过程中
一直想要放弃了好多次, 可是终不言弃这么超有用功能
最后万般努力, 绞尽脑汁, 耗了N多时间与精力, 灵机一动下终于获得的成功
实属不易, 拿出来当珍宝给献给大家.

也作为一份小礼感谢一路走来给予我阳光和温暖的各位大大
EHOME论坛的: 狼版 蓝版 MISSWU 赵钢...

你们的光和热让我现在有能量把这份热爱从巨人肩膀上分享给更多有需要的人.
谢谢! 感恩! 一点小小的分享作为让温暖在人类文明中不断链的微不足道的贡献.

< 思路和概念, 着急可跳过 >

这里省略了声明等部分, 仅把主干拿出来说明思路.
请参见注释描述

Public Function clipCopyFiles(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
      '把文件名数组中的各项目放入Data字符串中, 注意在各项目后+VBNULLCHAR
        For i = LBound(Files) To UBound(Files)
            Data = Data & Files(i) & vbNullChar
        Next i
　　 '最后再额外+一个VBNULLCHAR
        Data = Data & vbNullChar
        '为剪贴版拷贝操作分配相应大小的内存
        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, _
                Len(Data) + 15)
　　'注意这里的+15, 同上所述
            Call GlobalUnlock(hGlobal)

            '将数据拷贝到剪贴版上
            If SetClipboardData(CF_HDROP, hGlobal) Then
                clipCopyFiles = True
            End If
        End If
        Call CloseClipboard
    End If
End Function

< 具体代码文件已经打包整理好, 请下载享用 >


以下是一些扩展信息, 用于系统学习本文相关API
http://www.excelfans.com/2014/11/04/vba-windows-clipboard-02.html

xxdoc

会不会是Len(Data)这个len的问题呢?很多时候,带中文的数据大小会有问题

LIUZHU

楼主你好，最近在学习API函数Copymemery，关于这个DropFiles的结构体，有相关的学习资料吗？

suihuas

您好，谢谢您的分享，在您的基础上，我找到了自动微信文件的小程序，但运行起来，会弹出编译错误，“类型不匹配：缺少数组或用户定义类型“，我也不知道哪里的问题，可否帮忙查看一下，找一下原因呢？谢谢！

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub 自动发微信文件()
Dim af() As String, af2(), name(), i
Dim ws, sht As Worksheet
Set sht = ThisWorkbook.Sheets("sheet1")
af2 = Application.Transpose(sht.Range("A2:A" & sht.Range("A65535").End(xlUp).Row).Value)
name = Application.Transpose(sht.Range("C2:C" & sht.Range("C65535").End(xlUp).Row).Value)
Dim shp As Shape, picpath() As String
    Set ws = CreateObject("wscript.shell")
    ws.SendKeys "^%w"
    For i = LBound(name) To UBound(name)
       Sleep 500
       ws.Run "wshta vbscript:clipboardata.setdatal" & Chr(34) & "text" & Chr(34) & "." & Chr(34) & name(i) & Chr(34) & ")(close)", 0, True
       Sleep 500
       ws.SendKeys "^f"
    Sleep 500
    ws.SendKeys "^v"
    Sleep 500
    ws.SendKeys "{ENTER}"
    Sleep 500
    Debug.Print (clipCopyFiles(af2))
    Sleep 1500
    ws.SendKeys "^v"
    Sleep 1000
    ws.SendKeys "{ENTER}"
Next i
Set ws = Nothing
End Sub

suihuas

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub 自动发微信文件()
Dim af() As String, af2() As String, name(), i
Dim ws, sht As Worksheet
Set sht = ThisWorkbook.Sheets("sheet1")
af2 = Application.Transpose(sht.Range("A2:A" & sht.Range("A65535").End(xlUp).Row).Value)
name = Application.Transpose(sht.Range("C2:C" & sht.Range("C65535").End(xlUp).Row).Value)
Dim shp As Shape, picpath() As String
    Set ws = CreateObject("wscript.shell")
    ws.SendKeys "^%w"
    For i = LBound(name) To UBound(name)
       Sleep 500
       ws.Run "wshta vbscript:clipboardata.setdatal" & Chr(34) & "text" & Chr(34) & "." & Chr(34) & name(i) & Chr(34) & ")(close)", 0, True
       Sleep 500
       ws.SendKeys "^f"
    Sleep 500
    ws.SendKeys "^v"
    Sleep 500
    ws.SendKeys "{ENTER}"
    Sleep 500
    Debug.Print (clipCopyFiles(af2))
    Sleep 1500
    ws.SendKeys "^v"
    Sleep 1000
    ws.SendKeys "{ENTER}"
Next i
Set ws = Nothing
End Sub
Public Function clipCopyFiles(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
      '把文件名数组中的各项目放入Data字符串中, 注意在各项目后+VBNULLCHAR
        For i = LBound(Files) To UBound(Files)
            Data = Data & Files(i) & vbNullChar
        Next i
     '最后再额外+一个VBNULLCHAR
        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)
    '注意这里的+15, 同上所述
            Call GlobalUnlock(hGlobal)

            '将数据拷贝到剪贴版上
            If SetClipboardData(CF_HDROP, hGlobal) Then
                clipCopyFiles = True
            End If
        End If
        Call CloseClipboard
    End If
End Function
各位高手，以上语句运行起来，会弹出编译错误，“类型不匹配：缺少数组或用户定义类型“，我也不知道哪里的问题，可否帮忙查看一下，找一下原因呢？指点一下，谢谢啦！

gnodewww2

太牛了，感谢万分！！！我用用，成功了，得打赏了

gaolzhen

好东西 收藏了  

gaolzhen

不错，学习了