将单个或多个文件复制/剪切到剪切板源码(兼容64位/32位)

joforn · 发表于 2021-4-2 11:06

本帖最后由 joforn 于 2021-4-2 11:08 编辑

这是一段共享了很长时间的古老代码了，原来不支持64位系统，有些小伙伴自己不会修改成兼容64位代码，在私信中问，一下子又没找不到他的帖子，只好重新发送共享

'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>>>>>>>> Author: Joforn <<<<<<<<<<<<<<<<<<
'>>>>>>>> Email: [email]Joforn@sohu.com[/email] <<<<<<<<<<<<<<<<<<
'>>>>>>>> QQ: 42978116 <<<<<<<<<<<<<<<<<<
'>>>>>>>> Create time: 04/11/2012 <<<<<<<<<<<<<<<<<<
'>>>>>>>> Last time : 04/02/2021 <<<<<<<<<<<<<<<<<<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Option Explicit
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>\\\\\\\\\\\\\\\\\\\\\\\ API函数定义开始 /////////////////////////<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
#If VBA7 Then
Private Declare PtrSafe Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatW" (ByVal lpString As LongPtr) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function GlobalLock Lib "KERNEL32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalUnlock Lib "KERNEL32" (ByVal hMem As LongPtr) As Long
Private Declare PtrSafe Function GlobalAlloc Lib "KERNEL32" (ByVal flags As Long, ByVal Size As Long) As LongPtr
Private Declare PtrSafe Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (ByVal hpvDest As LongPtr, ByVal hpvSource As LongPtr, ByVal cbCopy As Long)
#Else
Private Declare Function RegisterClipboardFormat Lib "user32.dll" Alias "RegisterClipboardFormatW" (ByVal lpString 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 SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () 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 Function GlobalAlloc Lib "KERNEL32" (ByVal flags As Long, ByVal Size As Long) As Long
Private Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Byval hpvDest As Long,Byval hpvSource As Long, ByVal cbCopy As Long)
#End If
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>\\\\\\\\\\\\\\\\\\\\\\\ API函数定义结束 /////////////////////////<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
Private Const CF_HDROP As Long = 15&
Private Const DROPEFFECT_COPY As Long = 1
Private Const DROPEFFECT_MOVE As Long = 2
Private Const GMEM_ZEROINIT As Long = &H40
Private Const GMEM_MOVEABLE As Long = &H2
Private Const GMEM_DDESHARE As Long = &H2000
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'>\\\\\\\\\\\\\\\\\\\\\\\ 结构定义开始 /////////////////////////<
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
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
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
'>\\\\\\\\\\\\\\\\\\\\\\\ 结构定义结束 ////////////////////////<
'<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Public Function CutOrCopyFiles(FileList As Variant, Optional ByVal CopyMode As Boolean = True) As Boolean
Dim uDropEffect As Long, I As Long
Dim dropFiles As dropFiles
Dim uGblLen As Long, uDropFilesLen As Long
#If VBA7 Then
Dim hGblFiles As LongPtr
Dim hGblEffect As LongPtr
Dim mPtr As LongPtr
#Else
Dim hGblFiles As Long
Dim hGblEffect As Long
Dim mPtr As Long
#End If
Dim FileNames As String
If OpenClipboard(0) Then
EmptyClipboard
FileNames = GetFileListString(FileList)
If Len(FileNames) Then
uDropEffect = RegisterClipboardFormat(StrPtr("Preferred DropEffect"))
hGblEffect = GlobalAlloc(GMEM_ZEROINIT Or GMEM_MOVEABLE Or GMEM_DDESHARE, Len(uDropEffect))
mPtr = GlobalLock(hGblEffect)
I = IIf(CopyMode, DROPEFFECT_COPY, DROPEFFECT_MOVE)
CopyMemory mPtr, VarPtr(I), Len(I)
GlobalUnlock hGblEffect
SetClipboardData uDropEffect, hGblEffect
uDropFilesLen = LenB(dropFiles)
With dropFiles
.pFiles = uDropFilesLen
.fWide = CLng(True)
End With
uGblLen = uDropFilesLen + LenB(FileNames) + 8
hGblFiles = GlobalAlloc(GMEM_ZEROINIT Or GMEM_MOVEABLE Or GMEM_DDESHARE, uGblLen)
mPtr = GlobalLock(hGblFiles)
CopyMemory mPtr, VarPtr(dropFiles), uDropFilesLen
mPtr = mPtr + uDropFilesLen
hGblEffect = StrPtr(FileNames)
I = LenB(FileNames)
CopyMemory mPtr, hGblEffect, I
GlobalUnlock hGblFiles
SetClipboardData CF_HDROP, hGblFiles
End If
CloseClipboard
End If
End Function
Private Function GetFileListString(FileList As Variant) As String
Dim I As Long
On Error GoTo GetFileListStringLOOP
Select Case VarType(FileList)
Case vbString
GetFileListString = Trim$(FileList)
Case &H2008
For I = LBound(FileList) To UBound(FileList)
FileList(I) = Trim$(FileList(I))
If Len(FileList(I)) Then GetFileListString = GetFileListString & FileList(I) & vbNullChar
Next I
If Len(GetFileListString) Then GetFileListString = Left$(GetFileListString, Len(GetFileListString) - 1)
End Select
GetFileListStringLOOP:
End Function
Sub Test2Files()
Dim FileList() As String
ReDim FileList(0 To 1)
FileList(0) = "C:\Windows\regedit.exe"
FileList(1) = "C:\Windows\system32\gpedit.msc"
CutOrCopyFiles FileList
End Sub
Sub Test1File()
CutOrCopyFiles "C:\Windows\regedit.exe"
End Sub

复制代码

运行Test1File或Test2Files后，在Explorer中点右键粘贴可见效果。

zhiwei0 · 发表于 2021-4-2 14:12

我就是那个小伙伴，解决了悬了很久的问题，感谢楼主。这个功能对我太方便，太重要了，然而我对API一无所知。在32位系统用了很久到了64位突然用不了，每次要复制都要跑到文件夹里找很窝火。我一开始以为Joforn 是老外，原来是论坛里的大神，膜拜膜拜。谢谢谢谢谢过，以后还有很多跟系统兼容有关的问题想向楼主请教！！！

czr0373 · 发表于 2021-6-9 16:19

这个复制动作能改成ctrl+c就完美了

LIUZHU · 发表于 2021-9-23 15:33

楼主，能解释下dropFiles的数据结构吗，初看代码，不是很懂

joforn · 发表于 2021-9-23 16:06

LIUZHU 发表于 2021-9-23 15:33
楼主，能解释下dropFiles的数据结构吗，初看代码，不是很懂

https://docs.microsoft.com/zh-cn ... lobj_core-dropfiles

lilyhcn1 · 发表于 2021-9-23 17:52

本帖最后由 lilyhcn1 于 2021-9-23 18:50 编辑

收回我原来的话。

果然可以复制文件，另外居然没有一个杀毒软件报毒。佩服

joforn · 发表于 2021-9-23 17:58

lilyhcn1 发表于 2021-9-23 17:52
我猜很多软件会报毒

光猜是没有用的，试试就知道了。
如果这段小代码都报毒，那么那个杀毒软件基本已经倒闭了。

zhponer · 发表于 2022-5-10 15:23

应用到微信给别人发文件。不过代码看不懂。RegisterClipboardFormat(StrPtr("Preferred DropEffect"))，RegisterClipboardFormat 注册类型可以改成别的吧？

joforn · 发表于 2022-5-10 17:55

zhponer 发表于 2022-5-10 15:23
应用到微信给别人发文件。不过代码看不懂。RegisterClipboardFormat(StrPtr("Preferred DropEffect"))，Reg ...

可以，但是要目标程序能够识别

whlbliss · 发表于 2022-10-18 00:02

众里寻他千百度，蓦然回首，那人却在灯火阑珊处。谢谢楼主

		自动登录	找回密码
密码			免费注册

[分享] 将单个或多个文件复制/剪切到剪切板源码(兼容64位/32位)

评分