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

Question

我在这个论坛（和其他的......）中搜索了很多，但实际上我没有找到解决方案：

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

在要收集和存储的数据中，我还需要从每个分析的文件中拍摄几张图片（图片始终在同一张纸上并且始终具有相同的名称）。图片将仅在最终报告中使用。

我正在尝试将这些图片分配给对象类型变量并将它们收集在一个数组中（我想到了一个图片 A 的数组，其中数组的每个项目都应该包含来自 i- th 分析文件；图片 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 剪贴板，这会导致至少 2 个问题：

• 它相当（如果不是很）慢
• 在使用Paste方法之前，需要在Copy方法之后实现一些延迟（等待并检查图片是否已经真正复制到剪贴板），否则可能会出错。

有人有解决或优化这个问题的建议吗？

非常感谢！

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“Worksheet类的粘贴方法失败”

我猜是因为尝试在剪贴板中尚不可用时粘贴图片...

怎么办？只是尝试增加浪费的时间，直到不再出现错误？

谢谢！