VBA 剪切板

1. 插入类模块

在VBE中，插入一个类模块（注意是类模块，不是标准模块），并将其命名为“ClipBoard”，贴入下面的代码

Private Const CF_UNICODETEXT As Long = 13&
Private Const CF_TEXT As Long = 1&
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MOVEABLE = &H2
Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)
#If Win64 Then
	Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
	Private Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongLong) As Long
	Private Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongPtr
	Private Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtr
	Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtr
	Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
	Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongLong) As Long
	Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
	Private Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
	Private Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As String) As LongPtr
	Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
	Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongLong) As LongLong
	Private Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
	Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
#Else
	Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
	Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
	Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
	Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
	Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
	Private Declare Function CloseClipboard Lib "user32" () As Long
	Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long
	Private Declare Function EmptyClipboard Lib "user32" () As Long
	Private Declare Function CountClipboardFormats Lib "user32" () As Long
	Private Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
	Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
	Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
	Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
	Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
#End If

Public Function ClipBoard_HasFormat(ByVal peCBFormat) As Boolean
 Dim lRet As Long
 If OpenClipboard(0&) > 0 Then
   lRet = EnumClipboardFormats(0)
   If lRet <> 0 Then
     Do
       If lRet = peCBFormat Then
         ClipBoard_HasFormat = True
         Exit Do
       End If
       lRet = EnumClipboardFormats(lRet)
     Loop While lRet <> 0
   End If
     CloseClipboard
 Else
   MsgBox "不能打開剪切板", vbCritical
 End If
End Function

Public Function GetClipBoard() As String
#If Win64 Then
 Dim hData As LongPtr
 Dim lByteLen As LongPtr
 Dim lPointer As LongPtr
 Dim lSize As LongLong
#Else
 Dim hData As Long
 Dim lByteLen As Long
 Dim lPointer As Long
 Dim lSize As Long
#End If
 Dim lRet As Long
 Dim abData() As Byte
 Dim sText As String
 lRet = OpenClipboard(0&)
 If lRet > 0 Then
   hData = GetClipboardData(CF_TEXT)
   If hData <> 0 Then
     lByteLen = GlobalSize(hData)
     lSize = GlobalSize(hData)
     lPointer = GlobalLock(hData)
     If lSize > 0 Then
       ReDim abData(0 To CLng(lSize) - CLng(1)) As Byte
       CopyMemory abData(0), ByVal lPointer, lSize
       GlobalUnlock hData
       sText = StrConv(abData, vbUnicode)
     End If
   Else
     MsgBox "不能打開剪切板", vbCritical
   End If
     CloseClipboard
 End If
 GetClipBoard = sText
End Function

Public Function SetClipboard(clipText As String) As Boolean
 #If Win64 Then
 Dim hGlobalMemory As LongLong
 Dim lpGlobalMemory As LongPtr
 Dim hClipMemory As LongLong
 #Else
 Dim hGlobalMemory As Long
 Dim lpGlobalMemory As Long
 Dim hClipMemory As Long
 #End If
 
 Dim fOK As Boolean
 fOK = True
 #If Win64 Then
 hGlobalMemory = GlobalAlloc(GHND, LenB(clipText) + 1)
 #Else
 hGlobalMemory = GlobalAlloc(GHND, Len(clipText) + 1)
 #End If
 If hGlobalMemory = 0 Then
   Exit Function
 End If
 lpGlobalMemory = GlobalLock(hGlobalMemory)
 lpGlobalMemory = lstrcpy(lpGlobalMemory, clipText)
 If GlobalUnlock(hGlobalMemory) <> 0 Then
   fOK = False
   GoTo clean_exit
 End If
 If OpenClipboard(0&) = 0 Then
   fOK = False
   Exit Function
 End If
 EmptyClipboard
 hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
clean_exit:
 CloseClipboard
 ClipBoard_SetData = fOK
End Function

Public Sub ClearClipboard()
 OpenClipboard 0&
 EmptyClipboard
 CloseClipboard
End Sub

Public Function IsEmpty() As Boolean
 OpenClipboard 0&
 IsEmpty = (CountClipboardFormats = 0)
 CloseClipboard
End Function

Public Function IsString() As Boolean
 OpenClipboard 0&
 IsString = (IsClipboardFormatAvailable(CF_UNICODETEXT)) Or (IsClipboardFormatAvailable(CF_TEXT))
 CloseClipboard
End Function

Private Sub Class_Terminate()
 CloseClipboard
End Sub

2.插入标准模块

贴入下面代码

Sub PutInClipboard(ByVal strText As String)
 Dim clip As ClipBoard
 
 Set clip = New ClipBoard
 clip.SetClipboard strText
End Sub

3. 测试

调用这个Sub，传入想要复制到剪切板的文本了。

Call PutInClipboard("变量或者文本")