VBA实战技巧06： 复制文本到剪贴板

Sub CopyTextToClipboard()
   Dim objData As New DataObject
   Dim strText As String
   
   strText = "使用VBA复制到剪贴板!"
   
    '设置对象文本为字符串变量指定文本
   objData.SetText strText
    '将对象文本放置到剪贴板
   objData.PutInClipboard
End Sub

'处理64位和32位Office
#If VBA7 Then
 Private Declare PtrSafe Function GlobalUnlock Lib "kernel32"(ByVal hMem As LongPtr) As LongPtr
 Private Declare PtrSafe Function GlobalLock Lib "kernel32"(ByVal hMem As LongPtr) As LongPtr
 Private Declare PtrSafe Function GlobalAlloc Lib "kernel32"(ByVal wFlags As LongPtr, _
   ByVal dwBytes As LongPtr) As LongPtr
 Private Declare PtrSafe Function CloseClipboard Lib "user32"() As LongPtr
 Private Declare PtrSafe Function OpenClipboard Lib "user32"(ByVal hwnd As LongPtr) As LongPtr
 Private Declare PtrSafe Function EmptyClipboard Lib "user32" ()As LongPtr
 Private Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVallpString1 As Any, _
   ByVal lpString2 As Any) As LongPtr
 Private Declare PtrSafe Function SetClipboardData Lib "user32"(ByVal wFormat As LongPtr, _
   ByVal hMem As LongPtr) As LongPtr
#Else
 Private Declare Function GlobalUnlock Lib "kernel32" (ByValhMem As Long) As Long
 Private Declare Function GlobalLock Lib "kernel32" (ByVal hMemAs Long) As Long
 Private Declare Function GlobalAlloc Lib "kernel32" (ByValwFlags As Long, _
   ByVal dwBytes As Long) As Long
 Private Declare Function CloseClipboard Lib "user32" () AsLong
 Private Declare Function OpenClipboard Lib "user32" (ByValhwnd As Long) As Long
 Private Declare Function EmptyClipboard Lib "user32" () AsLong
 Private Declare Function lstrcpy Lib "kernel32" (ByVallpString1 As Any, _
   ByVal lpString2 As Any) As Long
Private Declare FunctionSetClipboardData Lib "user32" (ByVal wFormat _
   As Long, ByVal hMem As Long) As Long
#End If
 
Const GHND = &H42
Const CF_TEXT = 1
Const MAXSIZE = 4096
 
'复制文本到剪贴板的API函数
'来源:www.msdn.microsoft.com/en-us/library/office/ff192913.aspx
Function ClipBoard_SetData(MyString As String)
 
 Dim hGlobalMemory As Long, lpGlobalMemory As Long
 Dim hClipMemory As Long, X As Long
 
  '分配可移动的全局内存
 hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 20)
 
  '锁定该块以获取该内存的远指针
 lpGlobalMemory = GlobalLock(hGlobalMemory)
 
  '复制字符串到该全局内存
 lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
 
  '解锁该内存
 If GlobalUnlock(hGlobalMemory) <> 0 Then
   MsgBox "不能解锁内存位置. 复制中止."
   GoTo OutOfHere2
 End If
 
  '打开剪贴板复制数据.
 If OpenClipboard(0&) = 0 Then
   MsgBox "不能打开剪贴板. 复制中止."
   Exit Function
 End If
 
  '清空剪贴板
 X = EmptyClipboard()
 
  '复制数据到剪贴板
 hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
 
OutOfHere2:
 If CloseClipboard() = 0 Then
   MsgBox "不能关闭剪贴板."
 End If
End Function
 
Sub CopyTextToClipboard()
 Dim strText As String
 
 strText = "这里使用VBA复制文本到剪贴板!"
 
  '放置文本到剪贴板
  ClipBoard_SetData strText
End Sub