2023年12月13日发(作者：)
VBA操作剪切板
VBA操作剪切板
一，利用ject操作
1，什么是DataObject对象
传输操作中使用的格式化文本数据的保留区域。 还保留 DataObject 中存储的文本块所对应的 格式 的列表
DataObject 可包括一段针对剪贴板文本格式的文本和一段针对每种其他文本格式（如自定义格式和用户定义的格式）的文本。
DataObject 与剪贴板不同。 DataObject 支持涉及剪贴板和文本的拖放操作的命令。 在启动涉及剪贴板的操作（如 GetText）或拖放操作
时，该操作中涉及的数据将移动到 DataObject。
DataObject 的工作方式与剪贴板类似。 如果您将文本字符串复制到 DataObject，则 DataObject 将存储文本字符串。 如果您将同一格式
的第二个字符串复制到 DataObject，则 DataObject 将弃用第一个文本字符串并存储第二个字符串的副本。 它将存储一段指定格式的文本
并保留最近操作中的文本。
2，用vba操作剪切板注意
不要打开剪切板，同时只能一个操作，否则强制退出
3，声明方式
1. 前期绑定
勾选–>
Micorosoft Forms 2.0 Object LIbrary
2. 后期绑定
CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
4，文本写入剪切板
Sub test()
Dim jq As New ject
Dim ss As String
ss = "测试文本" '
文本变量
t ss '
赋值给
DataObject
lipboard '
写入剪切板
End Sub
5，读取剪切板文本
Sub test2()
Dim jq As New ject
Dim ss As String
mClipboard '
读取剪切板
ss = t '
调用方法得到文本
ss
End Sub
二，利用API操作剪切板
1，用到得API函数
1.
OpenClipboard
函数：作用是打开剪贴板
声明及引用：
Declare Function OpenClipboard Lib "user32" Alias "OpenClipboard" (ByVal hwnd As Long) As Long
如果调用成功，它会返回一个非0值；如果失败，则返回0；
如果有其他窗口已经打开剪贴板，这个函数会调用失败。
如果函数调用成功，一定要记得使用
CloseClipboard
函数关闭它。
2.
GetClipboardData
函数：作用是读取剪贴板里面的数据
声明及引用：
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
如果调用成功，返回剪贴板中以指定格式存放的剪贴板对象的句柄；
如果调用失败，返回Null；
在使用
GetClipboardData
之前，必须先成功调用
OpenClipboard
常用得几个常量
1. Public Const CF_TEXT = 1
2. Public Const CF_BITMAP = 2
3. Public Const CF_METAFILEPICT = 3
4. Public Const CF_SYLK = 4
3.
CopyMemory
函数将一定字节长度的数据从内存中的一个位置（源）复制到另一个位置（目的地）
声明及引用：
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
这个函数需要三个参数：
1.
Destination
：目的地的第一个字节的内存地址（指针）
2.
Source
: 源的第一个字节的内存地址（指针）
3.
Length
: 要复制的数据的长度
4.
GlobalLock
函数锁定一个全局内存对象并返回它所占用内存块的第一个字节的内存地址（指针）
声明及引用：
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
5.
GlobalSize
函数返回给定内存对象的字节长度
声明及引用：
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
6.
GlobalUnlock
函数将可移动(GMEM_MOVEABLE)内存对象的锁计数器数值－1，对于固定位置(GMEM_FIXED)的内存对象，这个函
数不起作用
简单说这个函数就是解锁内存指针和上面锁定对应
用到上面GlobalAlloc函数得到参数来解锁
声明及引用：
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
7.
CloseClipboard
函数关闭剪贴板
声明及引用：
Declare Function CloseClipboard Lib "user32"() As Long
8.
EmptyClipboard
函数清空剪切板
声明及引用：
Declare Function EmptyClipboard Lib "user32" () As Long
声明及引用：
Declare Function EmptyClipboard Lib "user32" () As Long
9. GlobalAlloc分配可移动的全局内存
声明及引用：
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
wFlags 参数给个常量：`Const GHND = &H42`
10. lstrcpy复制字符串到该全局内存
声明及引用：
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
lpString1 是要复制得内存指针地址，用`GlobalLock`得到
2，写入剪切板
'
处理
64
位和
32
位
Office
#If VBA7 And Win64 Then
Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, _
ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, _
ByVal hMem As LongPtr) As LongPtr
#Else
Private Declare Function GlobalUnlock Lib "kernel32" (ByValhMem As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMemAs Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByValwFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () AsLong
Private Declare Function OpenClipboard Lib "user32" (ByValhwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () AsLong
Private Declare Function lstrcpy Lib "kernel32" (ByVallpString1 As Any, _
ByVal lpString2 As Any) As Long
Private Declare FunctionSetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
#End If
Const GHND = &H42
Const CF_TEXT = 1
Const MAXSIZE = 4096
'
复制文本到剪贴板的
API
函数
'
来源
:/en-us/library/office/
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As LongPtr, lpGlobalMemory As LongPtr
Dim hClipMemory As LongPtr, X As LongPtr
'
分配可移动的全局内存
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 20)
'
锁定该块以获取该内存的远指针
lpGlobalMemory = GlobalLock(hGlobalMemory)
'
复制字符串到该全局内存
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
'
解锁该内存
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "不能解锁内存位置. 复制中止."
GoTo OutOfHere2
End If
'
打开剪贴板复制数据
.
If OpenClipboard(0&) = 0 Then
MsgBox "不能打开剪贴板. 复制中止."
Exit Function
End If
'
清空剪贴板
X = EmptyClipboard()
'
复制数据到剪贴板
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "不能关闭剪贴板."
End If
End Function
Sub CopyTextToClipboard()
Dim strText As String
strText = "这里使用VBA复制文本到剪贴板!"
'
放置文本到剪贴板
ClipBoard_SetData strText
End Sub
3，读取
代码
'
来源：
/p/214106380
#If VBA7 And Win64 Then
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
#Else
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
#End If
Private Const CF_TEXT = 1
Sub mynzB()
#If VBA7 And Win64 Then
Dim hMem As LongPtr
Dim lpData As LongPtr
Dim nClipSize As LongPtr
#Else
Dim hMem As Long
Dim lpData As Long
Dim nClipSize As Long
#End If
Dim bytClipData() As Byte
Dim sClipString As String
'Sheets("sheet1").Select
Range("A1:A3").Copy
If OpenClipboard(ByVal 0&) Then '
如果
OpenClipboard
函数返回非
0
值，说明成功打开剪贴板
hMem = GetClipboardData(CF_TEXT) '
获取剪贴板中以文本格式存在的内存对象的句柄
'
如果剪贴板中对应的格式不存在，此时的
hMem
会是
0(Null)
'
这里用
CBool
把它转换成
Boolean
类型加以判断
If CBool(hMem) Then
lpData = GlobalLock(hMem) '
获取内存对象第一个字节的内存地址
nClipSize = GlobalSize(hMem) '
获取内存对象的字节长度
'
修改缓冲字节数组的长度，确保能够容纳内存对象的全部数据
ReDim bytClipData(1 To CLng(nClipSize))
'
复制内存对象的数据到字节数组中，注意
Byval
的用法
CopyMemory bytClipData(1), ByVal lpData, nClipSize
sClipString = StrConv(bytClipData, vbUnicode) '
将字节转化成字符串
MsgBox "当前剪贴板内的文本是：" & vbCrLf & sClipString '
将结果显示给用户
Else
MsgBox "当前剪贴板内没有文本"
End If
CloseClipboard '
记住关闭，否则下次用报错
End If
End Sub
4， 提取剪贴板所有数据格式的代码
#If VBA7 And Win64 Then
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
'
这是获得剪切板格式用到得额外得
api
函数
Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As LongPtr, ByVal lpString As Stri
ng, ByVal nMaxCount As LongPtr) As LongPtr
#Else
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByValwFormat As Long) As Long
Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal n
MaxCount As Long) As Long
#End If
Private Const CF_TEXT = 1 '
文本常量
Private Const CF_BITMAP = 2 'Bitmap
对象
Private Const CF_METAFILEPICT = 3 'Metafile Picture
格式
Private Const CF_SYLK = 4 '
微软符号连接格式（
Microsoft Symbolic Link Format
）
Private Const CF_DIF = 5 'Software Arts' Data Interchange Format.
Private Const CF_TIFF = 6 '
标签图像文件格式（
TIFF
）
Private Const CF_OEMTEXT = 7 '
包含
OEM
字符集的文本格式
Private Const CF_DIB = 8 '
设备无关位图（
DIB
）格式，前面是一个
BITMAPINFO
结构，后面是图像像素位
Private Const CF_PALETTE = 9 '
调色板对象格式，当程序向剪贴板中放入一幅使用调色板的位图时，它需要同时将调色板也放入剪贴板
Private Const CF_PENDATA = 10 '
手写笔数据
Private Const CF_RIFF = 11 '
比标准
CF_WAVE
所能代表的音频格式更加复杂的音频格式
Private Const CF_WAVE = 12 '
标准音频格式（如
11kHz
或
22kHz
脉冲编码调制）的数据
Private Const CF_UNICODETEXT = 13 'Unicode
文本格式
Private Const CF_ENHMETAFILE = 14 '
增强图元文件格式
Private Const CF_HDROP = 15 '
文件名列表
Private Const CF_LOCALE = 16 '
与剪贴板内文本相关的区域选项的
ID
Private Const CF_MAX = 17
Dim lFormat As LongPtr
Sub mynzC()
Dim i
Sheets("SHEET2").Select
Cells().ClearContents
Sheets("SHEET4").Select
Cells(2, 1).Copy
Sheets("SHEET2").Select
If OpenClipboard(ByVal 0&) Then
lFormat = EnumClipboardFormats(0)
If lFormat <> 0 Then
i = 1
Cells(i, 1) = "格式代码"
Cells(i, 2) = "格式名称"
i = i + 1
Do While lFormat <> 0
Cells(i, 1) = lFormat
Cells(i, 2) = GetFormatName(lFormat)
i = i + 1
lFormat = EnumClipboardFormats(lFormat)
Loop
End If
CloseClipboard
End If
End Sub
Public Function GetFormatName(ByVal lFormat As LongPtr) As String
Select Case lFormat
Case 1
GetFormatName = "CF_Text"
Case 2
GetFormatName = "CF_Bitmap"
Case 3
GetFormatName = "CF_MetaFilePict"
Case 4
GetFormatName = "CF_SYLK"
Case 5
GetFormatName = "CF_Dif"
Case 6
GetFormatName = "CF_Tiff"
Case 7
GetFormatName = "CF_OEMText"
Case 8
GetFormatName = "CF_DIB"
Case 9
GetFormatName = "CF_Pallette"
Case 10
GetFormatName = "CF_PenData"
Case 11
GetFormatName = "CF_Riff"
Case 12
GetFormatName = "CF_Wave"
Case 13
GetFormatName = "CF_UnicodeText"
Case 14
GetFormatName = "CF_EnhMetaFile"
Case 15
GetFormatName = "CF_HDrop"
Case 16
GetFormatName = "CF_Locale"
Case 17
GetFormatName = "CF_Max"
Case Else:
'
以下是非标准部分
Dim sBuffer As String
sBuffer = String(100, Chr(0))
GetClipboardFormatName lFormat, sBuffer, 100
GetFormatName = Trim(sBuffer)
End Select
End Function
Sub mynzD()
CloseClipboard
End Sub
api弄得比较乱
5，整理一个上面用得全部api
#If VBA7 And Win64 Then
Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPtr
Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, ByVal Length As LongPtr)
Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
'
这是获得剪切板格式用到得额外得
api
函数
Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As LongPtr) As LongPtr
Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" _
(ByVal wFormat As LongPtr, ByVal lpString As String, ByVal nMaxCount As LongPtr) As LongPtr
Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, _
ByVal dwBytes As LongPtr) As LongPtr
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPtr
Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As LongPtr
Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As LongPtr, _
ByVal hMem As LongPtr) As LongPtr
#Else
Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CloseClipboard Lib "user32" () As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByValwFormat As Long) As Long
Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal n
MaxCount As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () AsLong
Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
ByVal lpString2 As Any) As Long
Private Declare FunctionSetClipboardData Lib "user32" (ByVal wFormat _
As Long, ByVal hMem As Long) As Long
#End If
Private Const CF_TEXT = 1 '
文本常量
Private Const CF_BITMAP = 2 'Bitmap
对象
Private Const CF_METAFILEPICT = 3 'Metafile Picture
格式
Private Const CF_SYLK = 4 '
微软符号连接格式（
Microsoft Symbolic Link Format
）
Private Const CF_DIF = 5 'Software Arts' Data Interchange Format.
Private Const CF_TIFF = 6 '
标签图像文件格式（
TIFF
）
Private Const CF_OEMTEXT = 7 '
包含
OEM
字符集的文本格式
Private Const CF_DIB = 8 '
设备无关位图（
DIB
）格式，前面是一个
BITMAPINFO
结构，后面是图像像素位
Private Const CF_PALETTE = 9 '
调色板对象格式，当程序向剪贴板中放入一幅使用调色板的位图时，它需要同时将调色板也放入剪贴板
Private Const CF_PENDATA = 10 '
手写笔数据
Private Const CF_RIFF = 11 '
比标准
CF_WAVE
所能代表的音频格式更加复杂的音频格式
Private Const CF_WAVE = 12 '
标准音频格式（如
11kHz
或
22kHz
脉冲编码调制）的数据
Private Const CF_UNICODETEXT = 13 'Unicode
文本格式
Private Const CF_ENHMETAFILE = 14 '
增强图元文件格式
Private Const CF_HDROP = 15 '
文件名列表
Private Const CF_LOCALE = 16 '
与剪贴板内文本相关的区域选项的
ID
Private Const CF_MAX = 17
Const GHND = &H42
Const MAXSIZE = 4096再比较常用得比如从剪切板导出图片
从剪切板读取图片到控件等，大同小异
发布评论