Excel VBA DataObject:PutInClipboard未实现 [英] Excel VBA DataObject:PutInClipboard Not Implemented
问题描述
我维护了一个包含大量VBA宏的Excel工作簿.该工作簿在过去的几个月中一直在使用，大多数情况下没有发生任何事件.我们有一个VBA函数，用于调用其他VBA函数.其目的是备份剪贴板数据，运行该功能，然后还原剪贴板数据.很简单.
I maintain an Excel workbook with a bunch of VBA macros in it. The workbook has been in use for the past few months, mostly without any incident. We have a VBA function that is used to call other VBA functions. The purpose of it is to back up clipboard data, run the function, then restore clipboard data. It's pretty simple.
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类是必需的.
The VBA project includes a reference to Microsoft Forms 2.0 Object Library (FM20.DLL), which is needed to use the DataObject class.
在除我的人以外的每个人的计算机上，该功能均应正常工作.它备份剪贴板数据，运行该功能，并还原剪贴板内容.
On everyone's computer except mine, the function works as it should. It backs up the clipboard data, runs the function, and restores the clipboard contents.
仅在我的计算机上出现此问题.每当我运行此功能，并且有一个空的剪贴板，或将纯文本复制到剪贴板(可以从excel或从外部源(如记事本)复制)时，都会引发错误.错误文字为
The issue is only occurring on my computer. Whenever I run this function, and I have an empty clipboard, or plain text copied to the clipboard (it could be copied from excel or from an outside source like notepad), an error is thrown. The text of the error is
运行时错误'-2147467263(80004001)':
Run-time error '-2147467263 (80004001)':
DataObject:PutInClipboard未实现.
DataObject:PutInClipboard Not implemented.
在行clipboardData.PutInClipboard上引发错误.永远不会抛出对clipboardData.GetFromClipboard的调用.对我来说，这意味着对Microsoft Forms 2.0对象库的引用没有任何问题.
The error is thrown on the line clipboardData.PutInClipboard. It is never thrown the call to clipboardData.GetFromClipboard. Which to me means that the reference to the Microsoft Forms 2.0 Object Library is not having any issues.
如果我在运行此宏之前将单元格或范围复制到剪贴板，也会抛出 not 错误.仅当剪贴板为空或包含纯文本数据时.
The error is also not thrown if I copy a cell or range to the clipboard before running this macro. Only when the clipboard is empty or contains plain text data.
在我的工作中，该错误从未在其他任何人的计算机上弹出.我已确保FM20.DLL存在于计算机上的正确文件夹中.我已重新启动Excel和计算机，但问题仍然存在.
The error has never popped up on anyone else's computer at my job. I have made sure that the FM20.DLL exists in the correct folder on my computer. I have restarted Excel and my computer but the issue persists.
当我将代码精简到此时，我会遇到相同的错误.
I get the same error when I reduce the code down to this.
Sub FunctionHandler()
Dim clipboardData As New DataObject
clipboardData.GetFromClipboard
clipboardData.PutInClipboard
End Sub
我还拥有该工作簿的多个完整备份副本，并且具有此功能的每个备份都给我带来相同的问题(但同样只有我一个人).
I also have multiple full backup copies of the workbook, and every single backup that has this function is giving me the same issues (but again, only me).
有人知道我该如何解决吗?
Does anyone know how I can fix this?
在我的计算机上使用新的Windows配置文件时，不会发生此问题.
This issue does not happen when using a new Windows profile on my computer.
推荐答案
我前段时间也遇到过类似的问题，这些是我遇到的最好的解决方案，可以满足您的要求(a)可以保存某些格式和其他有用的格式东西，b)只有字符串)
我在这里可以看到2种情况(及其解决方案/解决方法):
a)您只需要保存数据(但您的例程中随时都不会清除剪贴板).
在独立模块中，请执行以下操作:
I faced a similar issue a while ago, these are the best solutions I came across to do what you want (a) may save some formats and some other useful things, b) only strings)
I can see 2 scenarios here (and their solutions/workarounds):
a)You just need to save the data (but you are not clearing the clipboard at any moment in your routines).
In a stand alone module do the following:
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帮助中处理错误的代码，略有修改.逻辑相同，将其独立粘贴到模块中.
b) You are clearing the Data (or using the clipboard on it) and would like to preserve the original one (if any).
This is a slightly modified code from the one in Microsoft help to handle errors. Same logic, paste it standalone in a module.
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)方法时复制边距，颜色的解决方法
Note: Reference "FM20.dll" is the same one that I used for this testing.
More info at Microsoft
Workaround to copy margins,colors, when using b) method
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
More info if this doesn't fit your needs here, here and here.
这篇关于Excel VBA DataObject:PutInClipboard未实现的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
