Excel VBA：是否可以在不使用Windows剪贴板的情况下在工作簿之间复制和粘贴图片？

Question

我在这个论坛(和其他论坛…)搜索了很多，但我实际上没有找到一个解决方案:

[这里是问题的背景]我正在编写一个excel VBA程序，它将递归地打开文件夹中的所有excel文件，检索这些文件的大量数据，并将这些数据存储在程序文件本身的表(实际上是数据库)中。然后，存储的数据将用于检查、详细说明和报告。

在要收集和存储的数据中，我还需要从每个分析文件中获取几张图片(这些图片总是在相同的表上，并且总是具有相同的名称)。图片将只在最终报告中使用，并粘贴。

我试图将这些图片分配给对象类型变量，并将它们收集在一个数组中(我想到了图片a的数组，其中数组的每个项目应该包含来自第I个分析文件的图片a对象;图片B的第二个类似数组

[问题]我可以获得图片并将它们分配给对象变量，但我不能在数组中收集这样的对象。我想这在技术上是不可行的…

我找到的唯一解决方案是复制&粘贴图片:

For Each pic In SourceWorkbook.Sheets("source").Pictures
i = i + 1
pic.Copy
ThisWorkbook.Sheets("destination").Range("A" & i).PasteSpecial
With ThisWorkbook.Sheets("dst").Pictures(pic.Name)
.Name = "Pasted Picture #" & i
.Visible = False
End With
Next

但是我知道这种类型的解决方案使用WIndows剪贴板，导致至少两个问题:

• 它相当(如果不是非常)慢
• 在使用粘贴方法之前，需要在复制方法之后实现一些延迟(等待并检查图片已经在剪贴板中实际复制)，否则可能会发生错误。

有没有人有一些建议来解决或优化这个问题?

非常感谢!

Answer 1

现在，我发现唯一的解决方案是使用剪贴板复制。我使用的代码取自stackoverflow的另一个主题:

Option Explicit
'Does the clipboard contain a bitmap/metafile?
Public Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
'Open the clipboard to read
Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal Hwnd As LongPtr) As Long
'clear clipboard
Public Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
'Get a pointer to the bitmap/metafile
Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr 'wformat as long ?

'Close the clipboard
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long

'for waiting
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Clear_Clipboard()
OpenClipboard (0&)
EmptyClipboard
CloseClipboard
Application.CutCopyMode = False
End Sub

Sub PastePic(ByVal Pic As Shape, ByRef WB As Workbook, ByVal Sh As String, ByVal Rg As String)
Dim T#
Clear_Clipboard
Pic.Copy
'wait until the clipboard gets a pic, but not over 3 seconds (avoid infinite loop)
T = Timer
Do
Waiting (2)
Loop Until Is_Pic_in_Clipboard Or Timer - T > 1
WB.Sheets(Sh).Paste Destination:=WB.Sheets(Sh).Range(Rg) 'paste to a range without select

End Sub
Sub Waiting(ByVal Mili_Seconds&)
Sleep Mili_Seconds
End Sub
Function Is_Pic_in_Clipboard() As Boolean
If IsClipboardFormatAvailable(2) <> 0 Or IsClipboardFormatAvailable(14) <> 0 Then Is_Pic_in_Clipboard = True '2-14 =bitmap et Picture JPEG
End Function

但是这段代码有时还是会给我一些问题:

第1004号错误"工作表类的粘贴方法失败";

我猜这是由于尝试粘贴图片时，它还没有在剪贴板中可用…

该怎么办?只是试图增加时间浪费，直到我没有更多的错误?

谢谢!