VBA代码：复制文本到剪贴板

本文展示了如何使用VBA代码将一个字符串复制到剪贴板。那些刚接触VBA编程语言的人，VBA（Visual Basic for Application）主要用于使用MS Office应用程序（MS Excel、Word、Powerpoint等）实现重复性任务的自动化。有很多时候，你需要复制一些文本到剪贴板，而不将其存储在单元格或变量中。

如何使用VBA代码

1. 打开Excel工作簿
2. 按ALT+F11快捷键，打开Visual Basic编辑器(VBE)
3. 要插入一个模块，进入插入>模块
4. 将完整的VBA脚本粘贴在下面

许多流行的博客展示了如何使用Microsoft Forms 2.0 Object Library的方法将内容复制到剪贴板，但它不再工作，因为它返回两个问号。为了解决这个问题，我们需要依靠微软的API。下面的程序使用了API，代码分为两部分--API声明、用户定义的函数。

MS Excel 2010或以上版本使用VBA7版本。如果你还在使用MS Excel 2007或以下版本，它支持VBA 6.5或以下版本。

Option Explicit

#If VBA7 Then
  Declare PtrSafe Function GlobalUnlock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Declare PtrSafe Function GlobalLock Lib "kernel32" (ByVal hMem As LongPtr) As Long
  Declare PtrSafe Function GlobalAlloc Lib "kernel32" (ByVal wFlags As LongPtr, ByVal dwBytes As LongPtr) As Long
  Declare PtrSafe Function CloseClipboard Lib "User32" () As Long
  Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hwnd As LongPtr) As Long
  Declare PtrSafe Function EmptyClipboard Lib "User32" () As Long
  Declare PtrSafe Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
  Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As Long
#Else
  Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
  Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
  Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
  Declare Function CloseClipboard Lib "User32" () As Long
  Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
  Declare Function EmptyClipboard Lib "User32" () As Long
  Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
  Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
#End If

  Public Const GHND = &H42
  Public Const CF_TEXT = 1
  Public Const MAXSIZE = 4096

Public Function CopyToClipBoard(mytext As String) As Boolean

    Dim hGlobalMemory As Long
    Dim lpGlobalMemory As Long
    Dim hClipMemory As Long
    Dim X As Long
    
    On Error GoTo ExitWithError_

    ' Allocate moveable global memory
    hGlobalMemory = GlobalAlloc(GHND, Len(mytext) + 1)

    ' Lock the block to get a far pointer to this memory
    lpGlobalMemory = GlobalLock(hGlobalMemory)

    ' Copy the string to this global memory
    lpGlobalMemory = lstrcpy(lpGlobalMemory, mytext)

    ' Unlock the memory
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Memory location could not be unlocked. Clipboard copy aborted", vbCritical, "API Clipboard Copy"
        GoTo ExitWithError_
    End If

    ' Open the Clipboard to copy data to
    If OpenClipboard(0&) = 0 Then
        MsgBox "Clipboard could not be opened. Copy aborted!", vbCritical, "API Clipboard Copy"
        GoTo ExitWithError_
    End If

    ' Clear the Clipboard
    X = EmptyClipboard()

    ' Copy the data to the Clipboard
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
    CopyToClipBoard = True
    
    If CloseClipboard() = 0 Then
        MsgBox "Clipboard could not be closed!", vbCritical, "API Clipboard Copy"
    End If
    Exit Function
ExitWithError_:
    On Error Resume Next
    If Err.Number > 0 Then MsgBox "Clipboard error: " & Err.Description, vbCritical, "API Clipboard Copy"
    CopyToClipBoard = False

End Function

使用上述函数的例子
下面的代码是最基本的例子，你可以复制文本并粘贴到A1单元格。

Sub Example1()
    
    ' Copy Content
    CopyToClipBoard ("Hello, how are you?")
    
    'Paste
    Range("A1").Select
    ActiveSheet.Paste
    
    'Message when done
    MsgBox "Task Accomplished", vbInformation

End Sub