VBA代码：处理剪贴板

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

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