标签：VBA
下面的代码来源于ozgrid.com，可以用于设置、获取、清除剪贴板内容。
在VBE中，插入一个类模块，并将其重命名为“ClipBoard”，输入下面的代码：
代码语言：javascript复制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 OpenClipboard Lib "user32" (ByVal hWnd 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再插入一个标准模块，输入下面的代码进行测试：
代码语言：javascript复制Sub clipboardTest()
Dim clip As ClipBoard
Set clip = New ClipBoard
If Not clip.IsEmpty Then
'在"SetClipboard"之前"ClearClipboard"不是必需的.
'这里只是展示可用的函数
clip.ClearClipboard
End If
clip.SetClipboard "完美Excel!"
MsgBox clip.GetClipBoard, vbInformation
End Sub
