Question

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

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：

Worksheet类的粘贴方法失败

该代码适用于多个程序执行。

非常感谢任何帮助。

Answer 1

试试这个：

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

Answer 2

试试这个：

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

Answer 3

时间延迟产生了奇怪的结果。在某些情况下，一些照片被粘贴，而在其他情况下，它们并没有被粘贴。非常不一致的结果。

在子程序的最开始重新定位Application.wait ...代码 - 多次运行程序 - 完美地工作

永远不会猜到这个解决方案。感谢所有提出解决方案的人。

Answer 4

我也经常遇到这个问题。但是您不能等待每张图片3秒，这太长了。我正在处理1000张照片，它将永远拍摄。

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

如果您尝试在剪贴板上贴上Pic之前粘贴，则会出错。

因此，大量复制需要一些小的步骤：

清除Clipbard（并非始终需要，但可确保您不使用较旧的数据）
复制图片
测试Pic是否在剪贴板中，然后等待直到出现（循环）
粘贴

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

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

复制和;将图片从一张纸粘贴到另一张纸上

4 个答案: