將一張圖片從一張紙復制並粘貼到另一張紙上

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

Answer 5

我在復制圖片后使用命令“DoEvents”取得了成功。 這樣我在使用 Paste 時不會出錯，否則我會出錯。