Excel 复印及；将图片从一张纸粘贴到另一张纸上

我创建了一个小程序，使用以下代码将图片从同一工作簿中的一张图纸传输到另一张图纸

Sub transferPicturesPAPER_EXAM(pictureNo As Long, p As Integer, srcSht As String, dstSht As String, insertWhere As String)
'   Transfers the selected Picture to the exam sheet.
''zxx

    If pictureNo = 0 Then Exit Sub
    Sheets(srcSht).Select
    ActiveSheet.Unprotect
    ActiveSheet.pictures("Picture " & pictureNo).Select
    'ActiveSheet.Shapes.Range(Array("Picture " & pictureNo)).Select
    Selection.Copy

    Sheets(dstSht).Select
    Range(insertWhere).Select
    ActiveSheet.Paste

    '== rename to correspond to the problem number
    Selection.Name = "Picture " & p
End Sub

这个很好用。但是，当我将例程放在一个较大的工作簿中时，在第行出现以下错误：

Activesheet.paste

：

工作表类的粘贴方法失败

该代码在几个程序执行中运行良好

任何帮助都将不胜感激。

试试以下方法：

Sub transferPicturesPAPER_EXAM(pictureNo As Long, _
        p As Integer, srcSht As String, _
        dstSht As String, insertWhere As String)

'   Transfers the selected Picture to the exam sheet.
''zxx
    Dim pic As Picture

    If pictureNo = 0 Then Exit Sub

    Application.EnableEvents = False

    Sheets(srcSht).Unprotect
    Set pic = Sheets(srcSht).Pictures("Picture " & pictureNo)
    pic.Copy

    Sheets(dstSht).Activate
    Sheets(dstSht).Range(insertWhere).Select
    Sheets(dstSht).Paste

    '== rename to correspond to the problem number
    Selection.Name = "Picture " & p

    Application.EnableEvents = True
End Sub

试试这个：

Sub transferPicturesPAPER_EXAM(pictureNo As Long, p As Integer, srcSht As String, dstSht As String, insertWhere As String)

'   Transfers the selected Picture to the exam sheet.
''zxx
    Dim shpPictureToCopyAs Shape

    If pictureNo = 0 Then Exit Sub

    With Sheets(srcSht)
        .Unprotect
        Set shpPictureToCopy= .Shapes(pictureNo).Duplicate
        shpPictureToCopy.Cut
    End With

    Sheets(dstSht).Range(insertWhere).PasteSpecial (xlPasteAll)

End Sub

我建议在调用此程序的主程序中禁用和启用事件和屏幕更新。否则，您可以在不需要时启用它们。大概是这样的：

Sub MainProcedure() 'your sub name

    Application.EnableEvents = False
    Application.ScreenUpdating = False

    Call transferPicturesPAPER_EXAM(1, 1, "Sheet1", "Sheet2", "A20") 'with your variables as arguments of course

    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

---

时间延迟产生了奇怪的结果。在某些瞬间，一些图片被粘贴，而在另一些瞬间则没有。结果非常不一致

已重新定位应用程序。请稍候。。。子程序最开始的代码——运行程序几次——运行得非常好

我永远也猜不到这个解决方案。

---

感谢所有提出解决方案的人。

我也经常遇到这个问题。但是你不能在每张照片上等3秒钟，太长了。我拍了1000张照片，会拍到永远

问题的核心是Excel首先复制到windows剪贴板，这很慢

如果你试图在剪贴板上有图片之前粘贴，它会出错

因此，大规模复制需要一些小步骤：

• 清除clipbard（并非总是需要，但它可以确保您没有处理较旧的数据）
• 复制图片
• 测试Pic是否在剪贴板中，并等待它出现（循环）
• 粘贴

以下是代码（对于Excel 64位）：

选项显式
'剪贴板是否包含位图/图元文件？
公共声明PtrSafe函数IsClipboardFormatAvailable Lib“user32”（ByVal wFormat作为整数）的长度为
'打开剪贴板进行阅读
私有声明PtrSafe函数OpenClipboard Lib“user32”（ByVal Hwnd作为LongPtr）作为Long
'清除剪贴板
公共声明PtrSafe函数emptycipboard Lib“user32”（）的长度为
'获取指向位图/图元文件的指针
私有声明PtrSafe函数GetClipboardData库“user32”（ByVal wFormat As Long）为LongPtr'wFormat As Long？
'关闭剪贴板
私有声明PtrSafe函数CloseClipboard Lib“user32”（长度为
“等待
声明PtrSafe子睡眠库“kernel32”（ByVal-dwms长）
子清除_剪贴板（）
OpenClipboard（0&）
空电路板
关闭剪贴板
Application.CutCopyMode=False
端接头
子粘贴图片（图片作为形状）
变暗Rg As范围
暗T#
尺寸直线和：直线=5
Dim Sh_供应商作为工作表
Set SHU Vendeur=ThisWorkbook.Sheets（1）
清除剪贴板
图片，收到
设置Rg=Sh_供应商单元（Ligne，2）
'等待剪贴板获得图片，但不要超过3秒（避免无限循环）
T=计时器
做
等待（2）
循环，直到在剪贴板或计时器中显示图片-T>0.3
'Rg.Select
“Rg.PasteSpecial
Sh_vendur.Paste Destination:=Rg'粘贴到某个范围而不选择
端接头
子等待（ByVal Mili_秒&）
睡眠毫秒
端接头
函数在剪贴板（）中以布尔形式存在
如果IsClipboardFormatAvailable（2）0或IsClipboardFormatAvailable（14）0，则是剪贴板中的图片=真“2-14=位图和图片JPEG
端函数

尝试了所有方法，但每个方法在粘贴时都会产生一个错误-类似于范围类的paste特殊方法失败检查

插入位置是否有效。可能存在键入错误。如果没有，请尝试将
Application.Wait（现在+时间值（“00:00:03”））
放在粘贴行之前。在这里找到类似的东西，但我不知道Do事件在哪里。
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(Pic As Shape)
                    Dim Rg As Range
                    Dim T#
                    Dim Ligne&: Ligne = 5
                    Dim Sh_Vendeur As Worksheet
                    Set Sh_Vendeur = ThisWorkbook.Sheets(1)

                    Clear_Clipboard

                    Pic.Copy
                    Set Rg = Sh_Vendeur.Cells(Ligne, 2)

                    '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 > 0.3

                    'Rg.Select
                    'Rg.PasteSpecial
                    Sh_Vendeur.Paste Destination:=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