VBA 剪切板

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

Private Const CF_UNICODETEXT As Long = 13&Private Const CF_TEXT As Long = 1&Private Const GMEM_ZEROINIT = &H40Private Const GMEM_MOVEABLE = &H2Private Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)#If Win64 ThenPrivate 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 LongPrivate Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongLong) As LongPtrPrivate Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As LongLong) As LongPtrPrivate Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As LongPtrPrivate Declare PtrSafe Function CloseClipboard Lib "user32" () As LongPrivate Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hWnd As LongLong) As LongPrivate Declare PtrSafe Function EmptyClipboard Lib "user32" () As LongPrivate Declare PtrSafe Function CountClipboardFormats Lib "user32" () As LongPrivate Declare PtrSafe Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As Any, ByVal lpString2 As String) As LongPtrPrivate Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtrPrivate Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongLong) As LongLongPrivate Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As LongPrivate Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long#ElsePrivate 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 LongPrivate Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPrivate Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As LongPrivate Declare Function CloseClipboard Lib "user32" () As LongPrivate Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As LongPrivate Declare Function EmptyClipboard Lib "user32" () As LongPrivate Declare Function CountClipboardFormats Lib "user32" () As LongPrivate Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPrivate Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPrivate Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As LongPrivate Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long#End IfPublic 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 IfEnd FunctionPublic 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 = sTextEnd FunctionPublic 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 = fOKEnd FunctionPublic Sub ClearClipboard() OpenClipboard 0& EmptyClipboard CloseClipboardEnd SubPublic Function IsEmpty() As Boolean OpenClipboard 0& IsEmpty = (CountClipboardFormats = 0) CloseClipboardEnd FunctionPublic Function IsString() As Boolean OpenClipboard 0& IsString = (IsClipboardFormatAvailable(CF_UNICODETEXT)) Or (IsClipboardFormatAvailable(CF_TEXT)) CloseClipboardEnd FunctionPrivate Sub Class_Terminate() CloseClipboardEnd Sub

插入一个标准模块，贴入下面代码

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

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

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

来源地址：https://blog.csdn.net/wuchunyu002/article/details/133777231