copy & paste a picture from one sheet to another

问题

I created a small program using the following code to transfer a picture from one sheet to another in the same workbook.

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

This works fine. However, when I place the routine in a larger workbook, I get the following error at the line: Activesheet.paste:

Paste method of Worksheet class failed

The code worked fine for several program executions.

Any help would be greatly appreciated.

回答1:

Try this :

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

回答2:

Try this one :

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

I recommend disabling and enabling events and screen updating in the main procedure, from which this one has been called. Otherwise you can enable them when you dont want to. Something like this :

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:

The time delay produced weird results. In some instants some of the pictures were pasted and in others they weren't. Very inconsistent results.

Relocated the Application.wait ... code at the very beginning of the subroutine - ran the program several times - worked perfectly

Would never have guessed that solution. Thanks to everyone who suggested a solution.

回答4:

I often had this problem too. But you cannot wait 3 seconds per picture , it's too long. I work on 1000 pictures, it's gonna take for ever.

The core of the problem is that Excel copies to windows clipboard first, which is slow.

If you try to paste before the clipboard has the Pic , its will error.

So, some small steps needed for mass copying:

Clear clipbard (not always needed but it makes sure you are not working on older data)
Copy Pic
Test if Pic is in the Clipboard and wait until it is there (loop)
Paste

Here is the code (for Excel 64 bits) :

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

来源：https://stackoverflow.com/questions/28942028/copy-paste-a-picture-from-one-sheet-to-another

标签

excel-vba

copy-paste

vba

excel