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

2020-04-22 11:53:31 浏览数 (2)

可以使用VBA将文本复制到剪贴板，在需要使用时再将其粘贴到合适的地方。

下面的代码使用DataObject对象将指定文本复制到剪贴板：

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

注意，上述代码运行前需要添加对“Microsoft Forms 2.0 Object Library”库的引用，方法是在VBE中单击菜单“工具——引用”，在“引用”对话框中找到该库并选取。如果在“引用”对话框中找不到这个库，可以在VBE中单击菜单“插入——用户窗体”命令，先插入一个空白用户窗体，然后再运行上述代码。

还可以使用Windows API来复制文本到剪贴板。

代码语言：javascript复制
'处理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
api vba windows forms microsoft

0 人点赞