Question

我维护一个包含大量VBA宏的Excel工作簿。该工作簿在过去几个月中一直在使用，大多没有任何事件。我们有一个VBA函数，用于调用其他VBA函数。它的目的是备份剪贴板数据，运行该功能，然后恢复剪贴板数据。这很简单。

Sub FunctionHandler()
    Dim clipboardData As New DataObject
    clipboardData.GetFromClipboard

    '' There are a dozen or so macros that can be called here
    Call AnyFunction() 

    On Error Resume Next
    clipboardData.PutInClipboard
    On Error GoTo 0
End Sub

VBA项目包含对Microsoft Forms 2.0对象库（FM20.DLL）的引用，这是使用DataObject类所必需的。

在除了我的以外的所有人的计算机上，该功能可以正常工作。它备份剪贴板数据，运行该功能，并恢复剪贴板内容。

问题仅发生在我的电脑上。每当我运行这个函数，并且我有一个空的剪贴板，或者复制到剪贴板的纯文本（它可以从excel或从外部源如记事本复制）时，会引发错误。错误的文本是

运行时错误＆＃39; -2147467263（80004001）＆＃39;：

DataObject：PutInClipboard未实现。

错误行在clipboardData.PutInClipboard行。它永远不会被调用clipboardData.GetFromClipboard。对我来说意味着对Microsoft Forms 2.0对象库的引用没有任何问题。

如果在运行此宏之前将单元格或范围复制到剪贴板，则错误也会不抛出。仅当剪贴板为空或包含纯文本数据时。

在我的工作中，错误从未出现在任何其他人的计算机上。我已确保FM20.DLL存在于计算机上的正确文件夹中。我已经重新启动了Excel和我的计算机，但问题仍然存在。

当我将代码缩减到此时，我得到了同样的错误。

Sub FunctionHandler()
    Dim clipboardData As New DataObject
    clipboardData.GetFromClipboard

    clipboardData.PutInClipboard
End Sub

我还有多个工作簿的完整备份副本，每个具有此功能的备份都会给我同样的问题（但同样只有我）。

有谁知道如何解决这个问题？

编辑：在我的计算机上使用新的Windows配置文件时，不会发生此问题。

Answer 1

前一段时间我遇到过类似问题，这些是我遇到的最佳解决方案（a）可能会保存一些格式和其他一些有用的东西，b）只有字符串）我可以在这里看到2个场景（及其解决方案/解决方法）：
a）您只需要保存数据（但您没有在例程中随时清除剪贴板）。
在独立模块中执行以下操作：

Option Explicit
Private Declare Function OpenClipboard Lib "User32" _
(ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Sub SaveClipBoardContents()
    OpenClipboard 0
    CloseClipboard
End Sub
Sub ClearClipBoardContents()
    Application.CutCopyMode = False
End Sub

相应更改子

Sub FunctionHandler()
    Call SaveClipBoardContents

    '' There are a dozen or so macros that can be called here
    Call AnyFunction() 
    'clipboard will reamain because of the sub SaveClipBoardContents
End Sub

b）您正在清除数据（或使用其上的剪贴板），并希望保留原始数据（如果有）。 这是一个稍微修改过的代码，来自Microsoft帮助处理错误的代码。相同的逻辑，将其独立粘贴到模块中。

Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _
   As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function GetClipboardData Lib "User32" (ByVal wFormat As _
   Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags&, ByVal _
   dwBytes As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) _
   As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _
   ByVal lpString2 As Any) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Function ClipBoard_GetData()
   Dim hClipMemory As Long
   Dim lpClipMemory As Long
   Dim MyString As String
   Dim RetVal As Long
   If OpenClipboard(0&) = 0 Then: MsgBox "Cannot open Clipboard. Another app. may have it open": Exit Function
   ' Obtain the handle to the global memory
   ' block that is referencing the text.
   hClipMemory = GetClipboardData(CF_TEXT)
   If IsNull(hClipMemory) Then GoTo OutOfHere

   ' Lock Clipboard memory so we can reference
   ' the actual data string.
   lpClipMemory = GlobalLock(hClipMemory)

   If Not IsNull(lpClipMemory) Then
      MyString = Space$(MAXSIZE)
      RetVal = lstrcpy(MyString, lpClipMemory)
      RetVal = GlobalUnlock(hClipMemory)
      ' Peel off the null terminating character.
      On Error GoTo OutOfHere
      MyString = Mid(MyString, 1, InStr(1, MyString, Chr$(0), 0) - 1)
   Else
      MsgBox "Could not lock memory to copy string from."
   End If
OutOfHere:
   RetVal = CloseClipboard()
   ClipBoard_GetData = IIf(MyString = "OutOfHere", "", MyString)
End Function

改变你的潜艇

Sub FunctionHandler()
    Dim DataClipBoard As String
    Dim clipboardData As DataObject
    DataClipBoard = ClipBoard_GetData
    '...
    Application.CutCopyMode = False ' to simulate if clipboard is lost at some point
    '...
    Set clipboardData = New DataObject
    With clipboardData
        .SetText DataClipBoard
        .PutInClipboard
    End With
End Sub

注意：参考“FM20.dll”与我在此测试中使用的相同。更多信息，请访问Microsoft
的 编辑：
使用b）方法

时复制边距，颜色的解决方法
Sub FunctionHandler() Dim DataClipBoard As String Dim clipboardData As DataObject Dim RangeCopied As Range Set RangeCopied = Selection DataClipBoard = ClipBoard_GetData '... Application.CutCopyMode = False ' to simulate if clipboard is lost at some point '... If Not (RangeCopied.Find(Application.WorksheetFunction.Clean(Trim(Split(DataClipBoard, Chr(10))(1)))) Is Nothing) Then 'this is going to check if the data gathered in the copied clipboard is in the original selection, if so, this means this came from excel ' 1. If Not (RangeCopied.Find(Application.WorksheetFunction.Clean(Trim(Split(DataClipBoard, Chr(10))(1)))) Is Nothing) Then RangeCopied.Copy Else ' The data in clipboard didn't come from excel, so, just copy as plain text ' 1. If Not (RangeCopied.Find(Application.WorksheetFunction.Clean(Trim(Split(DataClipBoard, Chr(10))(1)))) Is Nothing) Then Set clipboardData = New DataObject With clipboardData .SetText DataClipBoard .PutInClipboard End With Set clipboardData = Nothing 'releases memory, data remain in CB End If ' 1. If Not (RangeCopied.Find(Application.WorksheetFunction.Clean(Trim(Split(DataClipBoard, Chr(10))(1)))) Is Nothing) Then End Sub

如果这不符合您的需求here，here和here，请提供更多信息。

Answer 2

我无法回答你为何遇到这个问题，但如果只是放入剪贴板，你可以尝试只交换下面的部分。它只处理字符串，所以它可能不适合你。

Sub PutDataInClipBoard(intext As String)
    Dim objShell As Object
    Set objShell = CreateObject("WScript.Shell")
    objShell.Run "cmd /C echo|set/p=" & intext & "| CLIP", 2
End Sub

Answer 3

为了解决您遇到的奇怪依赖问题，您是否可以尝试使用后期绑定等效替换早期绑定代码？

使用示例 - 请注意引用MSForms 2.0 Object Library：

的幻数

Option Explicit

Sub Test()

    ' set clipboard and test by pasting to range
    SetClipboard "hello world"
    Sheet1.Range("A1").PasteSpecial Paste:=xlPasteAll

End Sub

Sub SetClipboard(strToSet As String)

    Dim objDataObject As Object

    ' get clipboard with late binding
    Set objDataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    ' set input string to clipboard
    With objDataObject
        .SetText strToSet
        .PutInClipboard
    End With

    ' clean up    
    Set objDataObject = Nothing

End Sub

Excel VBA DataObject：未实现PutInClipboard

3 个答案: