VBA玩转系统剪贴板

前几天分享了博文《如何使用VBA将变量值拷贝到剪贴板？》，有的网友觉得使用的是旁门左道，今天来个根正苗红的Windows API解决方案。
示例代码如下。

Private Declare Function GlobalAlloc Lib _
                "kernel32.dll" (ByVal wFlags As Long, _
                            ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib _
                "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib _
                "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib _
                "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib _
                "kernel32.dll" Alias "lstrcpyW" _
                (ByVal lpString1 As Long, _
                ByVal lpString2 As Long) As Long
Private Declare Function OpenClipboard Lib _
                "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib _
                "user32.dll" () As Long
Private Declare Function CloseClipboard Lib _
                "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib _
                "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib _
                "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib _
                "user32.dll" (ByVal wFormat As Long, _
                            ByVal hMem As Long) As Long
                            
Public Function GetFromClipboard() As String
    Dim lngPtr      As Long
    Dim lngLength   As Long
    Dim lngGLock    As Long
    Dim strTxt      As String
    Const CF_UNICODETEXT As Long = 13&
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        lngPtr = GetClipboardData(CF_UNICODETEXT)
        If lngPtr Then
            lngGLock = GlobalLock(lngPtr)
            lngLength = GlobalSize(lngPtr)
            strTxt = String$(lngLength \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(strTxt), lngGLock
            GlobalUnlock lngPtr
        End If
        GetFromClipboard = strTxt
    End If
    CloseClipboard
End Function

Public Sub SetToClipboard(strTxt As String)
    Dim lngPtr      As Long
    Dim lngLength   As Long
    Dim lngGLock    As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    OpenClipboard 0&
    EmptyClipboard
    lngLength = LenB(strTxt) + 2&
    lngPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, lngLength)
    lngGLock = GlobalLock(lngPtr)
    lstrcpy lngGLock, StrPtr(strTxt)
    GlobalUnlock lngPtr
    SetClipboardData CF_UNICODETEXT, lngPtr
    CloseClipboard
End Sub

由于代码使用了多个API函数，并且涉及指针的概念，这里不再进行详细讲解，接下来看一下如何使用。

Sub Demo()
    Dim strMsg As String
    strMsg = "2021年"
    SetToClipboard strMsg
    ' 粘贴
    ActiveSheet.[a1].Select
    ActiveSheet.Paste
    ' 赋值
    ActiveSheet.[a2].Value = GetFromClipboard
End Sub

【代码解析】
SetToClipboard 将变量strMsg的值放置到系统剪贴板，在此之后可以使用第7行代码进行粘贴，也可以用9行代码直接为单元格赋值。当然也可以在其他应用程序中粘贴。