Excel VBA代码将特定字符串复制到剪贴板

Question

我正在尝试向电子表格添加一个按钮，单击该按钮会将特定 URL 复制到我的剪贴板。

我对 Excel VBA 有一点了解，但已经有一段时间了，我一直在苦苦挣扎。

Answer 1

编辑 - MSForms 已弃用，因此您不应再使用我的答案。而是使用这个答案：https://stackoverflow.com/a/60896244/692098

我把我原来的答案留在这里仅供参考：

Sub CopyText(Text As String)
    'VBA Macro using late binding to copy text to clipboard.
    'By Justin Kay, 8/15/2014
    Dim MSForms_DataObject As Object
    Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    MSForms_DataObject.SetText Text
    MSForms_DataObject.PutInClipboard
    Set MSForms_DataObject = Nothing
End Sub

用法：

Sub CopySelection()
    CopyText Selection.Text
End Sub

Answer 2

要向 Windows 剪贴板写入文本（或从中读取文本），请使用此 VBA 函数：

Function Clipboard$(Optional s$)
    Dim v: v = s  'Cast to variant for 64-bit VBA support
    With CreateObject("htmlfile")
    With .parentWindow.clipboardData
        Select Case True
            Case Len(s): .setData "text", v
            Case Else:   Clipboard = .getData("text")
        End Select
    End With
    End With
End Function

---

'Three examples of copying text to the clipboard:
Clipboard "Excel Hero was here."
Clipboard var1 & vbLF & var2
Clipboard 123

'To read text from the clipboard:
MsgBox Clipboard

这是一个不使用 MS Forms 或 Win32 API 的解决方案。相反，它使用 Microsoft HTML 对象库，该库快速且无处不在，并且不会像 MS Forms 那样被 Microsoft 弃用。而且这个解决方案尊重换行。此解决方案也适用于 64 位 Office。最后，此解决方案允许写入和读取 Windows 剪贴板。此页面上没有其他解决方案具有这些优势。

Answer 3

最简单的（非 Win32）方法是将用户窗体添加到您的 VBA 项目（如果您还没有），或者添加对 Microsoft Forms 2 对象库的引用，然后从您可以简单的工作表/模块：

With New MSForms.DataObject
    .SetText "http://zombo.com"
    .PutInClipboard
End With

Answer 4

如果 url 在工作簿的单元格中，您可以简单地复制该单元格中的值：

Private Sub CommandButton1_Click()
    Sheets("Sheet1").Range("A1").Copy
End Sub

（使用开发人员选项卡添加按钮。如果功能区不可见，请自定义它。）

如果 url 不在工作簿中，您可以使用 Windows API。下面的代码可以在这里找到：http://support.microsoft.com/kb/210216

添加下面的 API 调用后，更改按钮后面的代码以复制到剪贴板：

Private Sub CommandButton1_Click()
    ClipBoard_SetData ("http:\\stackoverflow.com")
End Sub

向您的工作簿添加一个新模块并粘贴以下代码：

Option Explicit

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

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

Function ClipBoard_SetData(MyString As String)
   Dim hGlobalMemory As Long, lpGlobalMemory As Long
   Dim hClipMemory As Long, X As Long

   ' Allocate moveable global memory.
   '-------------------------------------------
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 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, MyString)

   ' Unlock the memory.
   If GlobalUnlock(hGlobalMemory) <> 0 Then
      MsgBox "Could not unlock memory location. Copy aborted."
      GoTo OutOfHere2
   End If

   ' Open the Clipboard to copy data to.
   If OpenClipboard(0&) = 0 Then
      MsgBox "Could not open the Clipboard. Copy aborted."
      Exit Function
   End If

   ' Clear the Clipboard.
   X = EmptyClipboard()

   ' Copy the data to the Clipboard.
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)

OutOfHere2:

   If CloseClipboard() = 0 Then
      MsgBox "Could not close Clipboard."
   End If

End Function

Answer 5

添加对 Microsoft Forms 2.0 对象库的引用并尝试此代码。它仅适用于文本，不适用于其他数据类型。

Dim DataObj As New MSForms.DataObject

'Put a string in the clipboard
DataObj.SetText "Hello!"
DataObj.PutInClipboard

'Get a string from the clipboard
DataObj.GetFromClipboard
Debug.Print DataObj.GetText

Here你可以找到更多关于如何在 VBA 中使用剪贴板的细节。

Answer 6

如果您想使用即时窗口将变量的值放入剪贴板，您可以使用这一行轻松地在代码中放置断点：

Set MSForms_DataObject = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}"): MSForms_DataObject.SetText VARIABLENAME: MSForms_DataObject.PutInClipboard: Set MSForms_DataObject = Nothing

Answer 7

如果你要粘贴的地方粘贴表格格式没有问题（比如浏览器网址栏），我认为最简单的方法是这样：

Sheets(1).Range("A1000").Value = string
Sheets(1).Range("A1000").Copy
MsgBox "Paste before closing this dialog."
Sheets(1).Range("A1000").Value = ""

Answer 8

Microsoft 网站上给出的代码也可以在 Excel 中运行，即使它是在 Access VBA 下。我在 64 位 Windows 10 上的 Excel 365 中尝试过。

微软网站链接：https://docs.microsoft.com/en-us/office/vba/access/Concepts/Windows-API/send-information-to-the-clipboard

复制此处以确保答案的完整性。

Option Explicit
Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

Public Sub SetClipboard(sUniText As String)
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Public Function GetClipboard() As String
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Dim sUniText As String
    Const CF_UNICODETEXT As Long = 13&
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard
End Function

上面的代码可以从自定义宏中调用如下：

Sub TestClipboard()
    Dim Val1 As String: Val1 = "Hello Clipboard " & vbLf & "World!"
    SetClipboard Val1
    MsgBox GetClipboard
End Sub

要在表单上显示按钮，您可以通过快速搜索找到一个很好的示例。要在 Excel 自定义功能区中显示按钮（仅在当前 Excel 工作簿中显示的按钮），您可以使用 CustomUI。

自定义UI链接：

https://bettersolutions.com/vba/ribbon/custom-ui-editor.htm

https://docs.microsoft.com/en-us/office/open-xml/how-to-add-custom-ui-to-a-spreadsheet-document

带有图标的imageMSO列表（用于CustomUI）：

https://bert-toolkit.com/imagemso-list.html

谢谢。