VBA操作剪切板

VBA操作剪切板

一，利用MsForms.DataObject操作

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 MSForms.DataObject
    Dim ss As String
    
    ss = "测试文本"  '文本变量
    jq.SetText ss  '赋值给DataObject
    jq.PutInClipboard '写入剪切板
End Sub

5，读取剪切板文本

Sub test2()
    Dim jq As New MSForms.DataObject
    Dim ss As String
    
    jq.GetFromClipboard '读取剪切板
    ss = jq.GetText   '调用方法得到文本
    Debug.Print 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

    常用得几个常量

    • Public Const CF_TEXT = 1

    • Public Const CF_BITMAP = 2

    • Public Const CF_METAFILEPICT = 3

    • Public Const CF_SYLK = 4

  3. CopyMemory函数将一定字节长度的数据从内存中的一个位置（源）复制到另一个位置（目的地）

    声明及引用：Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

    这个函数需要三个参数：

    • Destination：目的地的第一个字节的内存地址（指针）

    • Source:　　　源的第一个字节的内存地址（指针）

    • 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

  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函数
'来源:www.msdn.microsoft.com/en-us/library/office/ff192913.aspx
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，读取

代码

'来源：https://zhuanlan.zhihu.com/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 String, 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 nMaxCount 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 nMaxCount 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

再比较常用得比如从剪切板导出图片
从剪切板读取图片到控件等，大同小异