跳转到内容

Visual Basic for Applications/剪贴板 VBA

Add links
来自维基教科书，开放的书籍，开放的世界

摘要

[编辑 | 编辑源代码]

主要有三种方法可以使用 VBA 代码将文本传递到剪贴板和从剪贴板中获取文本。

  • DataObject 方法
    • 这可能是最简单的实现。.
    • 其主要限制是，当启动应用程序关闭时，剪贴板内容将丢失；通常在运行 Excel 模块时这不是问题，但应牢记这一点。
    • 一些其他用户报告了错误。有关错误和一个建议的修复程序的详细信息，请参阅 DataObject 错误论坛。此页面上的所有过程都在 Windows 7 和 Windows 8.1 中针对 Excel 2010 进行了测试，并且运行良好。DataObject 方法最近已在该系列中针对 VBA 缩进模块采用。
    • 其他方法避免了这些限制。如果这些过程出现问题（这种情况不太可能发生），则可以使用接下来的两种方法中的任何一种。
    • DataObject 方法示例在该页面的第二部分给出。
  • 用户窗体控件方法
    • 当需要显示用户窗体时，可以使用文本框的复制和粘贴方法。这些方法运行良好，并且经过良好测试。
    • 当不需要显示用户窗体时，可以使用隐藏窗体。加载带有文本框的窗体，但不显示它。然后，仍然可以像正常一样对不可见的用户窗体的控件进行编码。对于大多数有用的文本传输，文本框必须将其Multiline 属性设置为true。通常最好将窗体的ShowModal 属性设置为False；这允许方便地进行代码跟踪，并避免许多其他混乱。
    • 隐藏用户窗体方法示例在第四部分给出。第三部分中另一个可见用户窗体示例显示了如何在复制之前跟踪活动文本框。
  • API 方法
    • 这些方法使用 Windows 库，并且在其模块标题中具有大量的声明。也就是说，它们运行良好，并且在 Microsoft 文档中被描述为最合适的。
    • API 使用示例在第五部分显示。有关更多详细信息，请参阅 将信息发送到剪贴板。

DataObject 方法

[编辑 | 编辑源代码]
  • 这些方法使用DataObject。它们是迄今为止最灵活的方法，因为可以放在变量中的任何文本都可以使用PutInClipboard 方法放在剪贴板上。还可以使用GetFromClipboard 方法将文本带入 VBA 字符串变量中。下面的示例中的CopyToClip() 和GetFromClip() 过程首先将文本发送到剪贴板，然后再次获取它，然后在消息框中显示文本。为此，在编辑器选项中设置对Microsoft Forms 2 的引用；如果找不到它，只需将用户窗体添加到您的项目中，它就会被添加到选择中。
  • 在其他地方报告了 DataObject 方法中的错误。这些适用于 Win 7 以外的 Windows 版本，据报道涉及对象和剪贴板之间不寻常的持久性。如果发现这些方法存在困难，则可以尝试虚拟用户窗体方法或 API 方法。
Sub testCopyAndPaste()
    'demonstrates copy and paste of text to variables
    'loads clipboard with date-time text then
    'fetches it back for display
    'Only good for text and clipboard content lost
    'when application closes.
        
    Dim sStrOut As String, sStrIn As String
    
    'get the current date-time string
    sStrOut = Now
    
    'copy text to clipboard
    CopyToClip sStrOut

    'retrieve from clipboard
    sStrIn = GetFromClip
    
    'display recovered text
    MsgBox sStrIn

End Sub

Function CopyToClip(sIn As String) As Boolean
    'passes the parameter string to the clipboard
    'set reference to Microsoft Forms 2.0 Object Library.
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    
    Dim DataOut As DataObject
    
    Set DataOut = New DataObject
    
    'first pass textbox text to dataobject
    DataOut.SetText sIn
    
    'then pass dataobject text to clipboard
    DataOut.PutInClipboard
    
    'release object variable
    Set DataOut = Nothing
    
    CopyToClip = True
    
End Function

Function GetFromClip() As String
    'passes clipboard text to function name
    'If clipboard not text, an error results
    'set reference to Microsoft Forms 2.0 Object Library.
    'If ref not listed, inserting user form will list it.
    'Clipboard cleared when launch application closes.
    
    Dim DataIn As DataObject
    
    Set DataIn = New DataObject
    
    'clipboard text to dataobject
    DataIn.GetFromClipboard
    
    'dataobject text to function string
    GetFromClip = DataIn.GetText
    
    'release object variable
    Set DataIn = Nothing
    
End Function

可见用户窗体方法

[编辑 | 编辑源代码]

下面的代码模块提供了窗体模块的 VBA 代码（此处显示为 UserForm1）。其中包含文本框Copy 和Paste 的命令按钮单击例程。要使用复制过程，用户只需选择一些文本，然后按用户窗体上的按钮即可。要将剪贴板的内容粘贴到文本框中，用户必须首先将插入点放在文本框中的某处，然后按所需的按钮。

为了澄清哪个文本框处于活动状态，每个文本框都有一个鼠标向上事件，每当在框中使用鼠标时，就会将一个数字加载到模块级变量中。尽管此代码是为三个文本框编写的，但它可以轻松地扩展到任意数量。

该代码假设有一个用户窗体 UserForm1，其中包含 TextBox1、TextBox2、TextBox3、CommandButton1 和 CommandButton2。此外，请注意代码中有一个模块级变量。由于 VBA 代码是通用的，因此它适用于大多数 MS Office 应用程序。

Option Explicit
Dim nActTxtBx As Integer

Private Sub CommandButton1_Click()
'this is the "Paste at Cursor" button
'pastes clipboard active textbox's insertion point
'ie; the textbox last clicked with mouse
            
    Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
    Dim oFrm As UserForm, oTxt As Control, s As Long
    
    Set oFrm = UserForm1
    Set oTxt1 = oFrm.TextBox1
    Set oTxt2 = oFrm.TextBox2
    Set oTxt3 = oFrm.TextBox3
    
    'get the textbox with the focus
    Select Case nActTxtBx
    Case 0
        MsgBox "Please place the insertion point."
        Exit Sub
    Case 1
        Set oTxt = oTxt1
    Case 2
        Set oTxt = oTxt2
    Case 3
        Set oTxt = oTxt3
    Case Else
        Exit Sub
    End Select
    
    s = oTxt.SelStart
    With oTxt
        .Paste
        .SetFocus
        .SelStart = s
    End With

    Set oFrm = Nothing: Set oTxt = Nothing
    Set oTxt1 = Nothing: Set oTxt2 = Nothing
    Set oTxt3 = Nothing
End Sub

Private Sub CommandButton2_Click()
'this is the "Copy Selected Text" button
'copies selected text from textbox to clipboard
'ie; the textbox last clicked with mouse

    Dim oTxt1 As Control, oTxt2 As Control, oTxt3 As Control
    Dim oFrm As UserForm, oTxt As Control
    
    Set oFrm = UserForm1
    Set oTxt1 = oFrm.TextBox1
    Set oTxt2 = oFrm.TextBox2
    Set oTxt3 = oFrm.TextBox3
    
    'get reference to active textbox
    Select Case nActTxtBx
    Case 0
        MsgBox "Please make a selection."
        Exit Sub
    Case 1
        Set oTxt = oTxt1
    Case 2
        Set oTxt = oTxt2
    Case 3
        Set oTxt = oTxt3
    Case Else
        Exit Sub
    End Select
    
    'check that a selection was made
    'MsgBox oTxt.SelLength
    If oTxt.SelLength = 0 Then
        MsgBox "No selection found."
        Exit Sub
    End If
    
    With oTxt
        .Copy
        .SetFocus
        .SelStart = 0
    End With

    Set oFrm = Nothing: Set oTxt = Nothing
    Set oTxt1 = Nothing: Set oTxt2 = Nothing
    Set oTxt3 = Nothing

End Sub

Private Sub TextBox1_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 1
End Sub

Private Sub TextBox2_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 2
End Sub

Private Sub TextBox3_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, _
                                ByVal X As Single, ByVal Y As Single)
    'loads an integer to denote active textbox when mouse makes selection
    nActTxtBx = 3
End Sub

隐藏用户窗体方法

[编辑 | 编辑源代码]

此代码应放在标准模块中。该项目需要一个名为Temp 的用户窗体，其中包含一个设置为 MultiLine=true 的 TextBox1。文本框内容始终为文本。

Option Explicit

Sub TestClipboardProcs()
'run this
    
    CopyToClipboard "The string" & vbCrLf & _
                    "to copy..."
    MsgBox GetClipboard2

End Sub

Function GetClipboard2() As String
'PASTES clipboard into function name as a text string
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
    
    Dim oTxt1 As Control, oFrm As UserForm
    Dim s As Long
    
    'load the temporary form
    Load Temp
    
    Set oFrm = Temp
    Set oTxt1 = oFrm.TextBox1
        
    s = oTxt1.SelStart
    With oTxt1
        .Paste
        .SetFocus
        .SelStart = s
    End With
    
    GetClipboard2 = oTxt1.Value
        
    Set oTxt1 = Nothing
    Set oFrm = Nothing
    Unload Temp

End Function

Function CopyToClipboard(sStr As String) As Boolean
'COPIES parameter variable text string value to clipboard
'project needs userform named Temp
'with TextBox1 in it set with property Multiline=true
    
    Dim oTxt1 As Control, oFrm As UserForm
    
    If sStr = "" Then
        MsgBox "Clipboard cannot hold an empty string."
        Exit Function
    End If
        
    'load the temporary form
    Load Temp
    
    Set oFrm = Temp
    Set oTxt1 = oFrm.TextBox1
    
    oTxt1.Value = sStr
        
    'copy textbox value to clipboard
    With oTxt1
        .SelStart = 0 'set up the selection
        .SelLength = .TextLength
        .Copy
        .SetFocus
        .SelStart = 0
    End With
        
    Set oTxt1 = Nothing
    Set oFrm = Nothing
    Unload Temp

    CopyToClipboard = True

End Function

API 方法

[编辑 | 编辑源代码]

下面的代码是在 Excel 的 Office 2010 版本（32 位系统）上测试的，并且运行良好。从那时起，在 64 位 2019 Excel 中，该代码无法在其当前状态下运行，而是需要针对 64 位使用进行进一步更改。

以下 VBA 代码使用 API 调用，并由 Microsoft 在其 MS Access 页面 将信息发送到剪贴板 中推荐。此类方法应克服 Windows 8 和 10 中DataObject 方法的当前错误。该代码应完整地复制到标准模块中。

Option Explicit
'Declarations for functions SetClipboard() and GetClipboard()
''from https://docs.microsoft.com/en-us/office/vba/access/concepts/windows-api/send-information-to-the-clipboard
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

Sub TestCopyPasteAPI()
    'API methods for clipboard
    Dim sIn As String, sOut As String
    
    sIn = "Sausages"
    SetClipboard sIn
    sOut = GetClipboard
    MsgBox sOut

End Sub

Public Sub SetClipboard(sUniText As String)
    'sets the clipboard with parameter string
      
    Dim iStrPtr As Long, 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
    'gets the clipboard text in function name
    
    Dim iStrPtr As Long, iLen As Long
    Dim iLock As Long, 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

另请参阅

[编辑 | 编辑源代码]
  • 将信息发送到剪贴板：Microsoft 的一篇措辞清晰的页面，展示了如何使用 API 方法访问剪贴板。虽然针对 MS Access 描述，但在 MS Excel 中同样有效。
  • DataObject 错误论坛：Win7 以外的 Windows 版本中 DataObject 错误的描述。
检索自 "https://wikibooks.cn/w/index.php?title=Visual_Basic_for_Applications/Clipboard_VBA&oldid=4300695"
华夏公益教科书