Shapes Copy Paste Timing Issue - Excel VBA

Question

I am using Windows 10 Enterprise 64 bit, Office 2016 Pro 64 bit. I am trying to copy 2 shapes from one worksheet to another worksheet.

The following API code works sometimes, but most times it shoots an Error 1004 for Copy or Paste (Clipboard timing issue). I have tried using different solutions e.g. Timer, Wait, API etc., but seem slow and buggy most of the times! Also i am trying to paste the images on opposite ends of each merged cell. I have also attached a sample file for inspection.

I don't remember but i read somewhere that if i create separate copy and paste functions/procedures, then it might solve the issue, though not sure!

Option Explicit

Sub DoIT()

    Dim Shp1 As Shape, Shp2 As Shape, Shp3 As Shape, Shp4 As Shape, i&, j&
    Dim WK1 As Worksheet, WK2 As Worksheet

    With ThisWorkbook
        Set WK1 = .Worksheets("test1")
        Set WK2 = .Worksheets("test2")
        Set Shp1 = WK1.Shapes("Arrow")
        Set Shp2 = WK1.Shapes("Consumers")

        j = 0
        For i = 1 To 20

            With WK2.Range(WK2.Cells(i + j, 3), WK2.Cells(i + j, 4))
                .Merge  'merge 2 cells

                On Error Resume Next
                Do
                    ClearClipboard
                    Shp1.CopyPicture
                    WaitOnClipboard
                Loop Until Err.Number = 0
                On Error GoTo 0
'                Pause

                'copy paste Arrow shape
                On Error Resume Next
                Do
                    Err.Clear
                    WK2.Paste Destination:=WK2.Cells(i + j, 3) ', link:=False
                    DoEvents
                Loop Until Err.Number = 0
                On Error GoTo 0
                Application.CutCopyMode = False
                ClearClipboard

                Set Shp3 = WK2.Shapes(WK2.Shapes.Count)
                With Shp3
                    .Top = WK2.Cells(i + j, 3).MergeArea.Top
                    .Left = WK2.Cells(i + j, 3).MergeArea.Left
                End With


                ' copy paste Consumers shape
                On Error Resume Next
                Do
                    ClearClipboard
                    Shp2.CopyPicture
                    WaitOnClipboard
                Loop Until Err.Number = 0
                On Error GoTo 0
'                Pause

                On Error Resume Next
                Do
                    Err.Clear
                    WK2.Paste Destination:=WK2.Cells(i + j, 3) ', link:=False
                    DoEvents
                Loop Until Err.Number = 0
                On Error GoTo 0
                Application.CutCopyMode = False
                ClearClipboard

                Set Shp4 = WK2.Shapes(WK2.Shapes.Count)
                With Shp4
                    .Top = WK2.Cells(i + j, 3).MergeArea.Top
                    .Left = WK2.Cells(i + j, 3).MergeArea.Left + WK2.Cells(i, 3).MergeArea.Width - Shp2.Width
                End With
                j = j + 2
            End With
        Next i
    End With
End Sub

The API code:

Option Explicit

' Windows API declarations
#If VBA7 Or Win64 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Declare PtrSafe Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Declare PtrSafe Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Declare PtrSafe Function CountClipboardFormats Lib "user32" () As Long
#Else
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
    Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function CloseClipboard Lib "user32" () As Long
    Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
    Declare Function EmptyClipboard Lib "user32" () As Long
    Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
    Declare Function CountClipboardFormats Lib "user32" () As Long
#End If

Public Sub WaitOnClipboard()
  Do
    DoEvents
'  Loop Until IsPicInClipboard
  Loop Until IsPicOnClipboard
End Sub

' Wait until PowerPoint shape object is on the Windows clipboard
Public Sub WaitForClipboard()
  Do
    DoEvents
'  Loop Until IsPicInClipboard
  Loop Until IsPicOnClipboard
End Sub

Function IsShapeOnClipboard() As Boolean
    If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
    IsShapeOnClipboard = IsClipboardFormatAvailable(&HC216&)
    EmptyClipboard
    CloseClipboard
End Function

Function IsPicInClipboard() As Boolean
    If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
    IsPicInClipboard = False
    If IsClipboardFormatAvailable(2) <> 0 Or _
          IsClipboardFormatAvailable(3) <> 0 Or _
          IsClipboardFormatAvailable(9) <> 0 Or _
          IsClipboardFormatAvailable(14) <> 0 Or _
          IsClipboardFormatAvailable(25) <> 0 Or _
          IsClipboardFormatAvailable(29) <> 0 Then IsPicInClipboard = True
End Function

' Check if PowerPoint shape object is on the Windows clipboard
Public Function IsPicOnClipboard() As Boolean

    Dim lFormat As Long
    Dim sName As String

    If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard
    Do
        lFormat = EnumClipboardFormats(lFormat)
'        sName = String(255, 0)
'        sName = Space(255)
'        GetClipboardFormatName lFormat, sName, Len(sName)
'        Debug.Print lFormat, sName
'        If sName Like "*PowerPoint 12.0 Internal Shapes*" Then IsPicOnClipboard = True: Exit Do
'        If InStr(1, Trim(lFormat), "14", vbTextCompare) > 0 Then IsPicOnClipboard = True: Exit Do
        If (lFormat = 2 Or lFormat = 3 Or lFormat = 9 Or lFormat = 14 Or lFormat = 25 Or lFormat = 29) Then IsPicOnClipboard = True: Exit Do
    Loop Until lFormat = 0

    CloseClipboard

End Function

Public Sub Pause()
    Dim t As Double

    t = Timer
    Do Until Timer - t > 1
      DoEvents
    Loop
End Sub

Function IsClipboardEmpty() As Boolean
    IsClipboardEmpty = (CountClipboardFormats() = 0)
End Function

Public Function ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Function

Public Sub CopyShape(ItemName As String, ByRef CopyDestination As Worksheet, ByRef PasteDestination As Worksheet)
    Call ClearClipboard

    ThisWorkbook.Sheets(CopyDestination).Shapes(ItemName).Copy
    ThisWorkbook.Sheets(PasteDestination).Paste

    Do Until IsClipboardEmpty = False
        DoEvents
    Loop

End Sub

Function Is_Pic_in_Clipboard() As Boolean
    If OpenClipboard(0&) = 0 Then Exit Function ' Could not open clipboard

    If IsClipboardFormatAvailable(2) <> 0 Or IsClipboardFormatAvailable(14) <> 0 Or IsClipboardFormatAvailable(9) <> 0 Then _
        Is_Pic_in_Clipboard = True '2=BMP, 14=JPEG, 9=Picture
End Function

Sub ListClipFormats()
    Dim Arr, Fmt

    Arr = Application.ClipboardFormats

    For Each Fmt In Application.ClipboardFormats
        Select Case Fmt
            Case xlClipboardFormatBIFF Or 8: Debug.Print "Binary Interchange file format for Excel version 2.x"
            Case xlClipboardFormatBIFF12 Or 63: Debug.Print "Binary Interchange file format 12"
            Case xlClipboardFormatBIFF2 Or 18: Debug.Print "Binary Interchange file format 2"
            Case xlClipboardFormatBIFF3 Or 20: Debug.Print "Binary Interchange file format 3"
            Case xlClipboardFormatBIFF4 Or 30: Debug.Print "Binary Interchange file format 4"
            Case xlClipboardFormatBinary Or 15: Debug.Print "Binary format"
            Case xlClipboardFormatBitmap Or 9: Debug.Print "Bitmap format"
            Case xlClipboardFormatCGM Or 13: Debug.Print "CGM format"
            Case xlClipboardFormatCSV Or 5: Debug.Print "CSV format"
            Case xlClipboardFormatDIF Or 4: Debug.Print "DIF format"
            Case xlClipboardFormatDspText Or 12: Debug.Print "Dsp Text format"
            Case xlClipboardFormatEmbeddedObject Or 21: Debug.Print "Embedded Object"
            Case xlClipboardFormatEmbedSource Or 22: Debug.Print "Embedded Source"
            Case xlClipboardFormatLink Or 11: Debug.Print "Link"
            Case xlClipboardFormatLinkSource Or 23: Debug.Print "Link to the source file"
            Case xlClipboardFormatLinkSourceDesc Or 32: Debug.Print "Link to the source description"
            Case xlClipboardFormatMovie Or 24: Debug.Print "Movie"
            Case xlClipboardFormatNative Or 14: Debug.Print "Native"
            Case xlClipboardFormatObjectDesc Or 31: Debug.Print "Object description"
            Case xlClipboardFormatObjectLink Or 19: Debug.Print "Object link"
            Case xlClipboardFormatOwnerLink Or 17: Debug.Print "Link to the owner"
            Case xlClipboardFormatPICT Or 2: Debug.Print "Picture"
            Case xlClipboardFormatPrintPICT Or 3: Debug.Print "Print picture"
            Case xlClipboardFormatRTF Or 7: Debug.Print "RTF format"
            Case xlClipboardFormatScreenPICT Or 29: Debug.Print "Screen Picture"
            Case xlClipboardFormatStandardFont Or 28: Debug.Print "Standard Font"
            Case xlClipboardFormatStandardScale Or 27: Debug.Print "Standard Scale"
            Case xlClipboardFormatSYLK Or 6: Debug.Print "; SYLK"
            Case xlClipboardFormatTable Or 16: Debug.Print "; Table"
            Case xlClipboardFormatText Or 0: Debug.Print "Text"
            Case xlClipboardFormatToolFace Or 25: Debug.Print "Tool Face"
            Case xlClipboardFormatToolFacePICT Or 26: Debug.Print "Tool Face Picture"
            Case xlClipboardFormatVALU Or 1: Debug.Print "Value"
            Case xlClipboardFormatWK1 Or 10: Debug.Print "Workbook"
        End Select
    Next Fmt

End Sub

Public Sub ListClipboardFormats()

    Dim lFormat As Long
    Dim sName As String

    If OpenClipboard(0&) = 0 Then Exit Sub ' Could not open clipboard
    Do
        lFormat = EnumClipboardFormats(lFormat)
        sName = String(255, 0)
        GetClipboardFormatName lFormat, sName, Len(sName)
        If Not lFormat = 0 Then Debug.Print lFormat, sName
    Loop Until lFormat = 0

    EmptyClipboard
    CloseClipboard

End Sub

EDIT:

@iinspectable, it is not a normal Copy-Paste issue, but a clipboard timing issue if copy paste is involved in a loop i.e. copy paste done multiple times. Here's an example where the SingleCopyPaste procedure works, but not the MultipleCopyPaste procedure. I hope you get my point now.

Option Explicit

Sub MultipleCopyPaste()
    Dim shp As Shape

   For Each shp In Sheet1.Shapes
      shp.CopyPicture
      Sheet2.Paste Sheet2.Range(shp.TopLeftCell.Address)
    Next shp
End Sub


Sub SingleCopyPaste()
    Dim shp As Shape

    Set shp = Sheet1.Shapes("Arrow")
    shp.CopyPicture
   Sheet2.Paste Sheet2.Range(shp.TopLeftCell.Address)

End Sub

The obvious question is: Why are you (ab)using the clipboard for this? — IInspectable, Mar 07 '20 at 16:24
Since this didn't come through, let me rephrase the question: Why don't you just copy the objects, without relying on the system's clipboard (which belongs to the user, not you)? — IInspectable, Mar 07 '20 at 16:28
I was doing that earlier, but since i wasn't able to copy paste properly, had to resort to WinAPI to pause between copy pastes. Hope this is clear. — sifar, Mar 07 '20 at 16:30
No, not really. You are trying to copy an object from one worksheet to another worksheet. That's not an operation that requires the clipboard. If you are using the clipboard, because some undisclosed code *"didn't work"*, then maybe you should try fixing that code. — IInspectable, Mar 07 '20 at 16:41
Sorry if i am missing something here. Honestly i do not understand what you mean. I am copying and pasting 2 shapes from Test1 sheet to Test2 sheet, `multiple times` using a for loop. Thats when the copy paste timing errors like Error 1004 occur. If you open the Clipboard, you will see multiple copies are created but only 1 or 2 are getting pasted each time i.e. before 1st copy gets pasted from clipboard, the next copy gets onto clipboard. So getting incorrect copy-pastes or sometimes errors. `See attached Excel file.` — sifar, Mar 07 '20 at 16:47
@COY, I am copy pasting from 1 sheet to another sheet. See my attached sample excel file. Normal copy pasting was not working without errors, so resorted to Win32 API code, but thats also buggy i.e. not very optimized and error prone. — sifar, Mar 07 '20 at 16:52
I fail to see, why the clipboard is involved in all of this. *"Normal copy pasting was not working without errors"* seems to be your real issue. But you don't seem to want to fix that. — IInspectable, Mar 07 '20 at 17:07
This is a problem I've had on Office 365 - a looped copy/paste would fail but then it continuing after the error it would succeed. I ended up using the approach I posted here, whichc seems to work OK - https://stackoverflow.com/questions/60063795/run-time-error-1004-microsoft-excel-cannot-paste-the-data/60065424#60065424 — Tim Williams, Mar 07 '20 at 21:55
@IInspectable - "That's not an operation that requires the clipboard" - where else would the shape go when you copy it? — Tim Williams, Mar 07 '20 at 22:06
@tim: It's already there, in local memory, referenced through the variable `shp`. No need to allocate system-global memory, thereby trashing the user's clipboard. Just use the object. — IInspectable, Mar 08 '20 at 06:05
@iinspectable could you demonstrate what you mean with example code? The problem is to have multiple copies of a shape placed in different positions in another sheet. How would you do that without a copy paste or in other words, copying the shape to the clipboard and pasting it from the clipboard? — sifar, Mar 08 '20 at 06:11
@IInspectable How can a shape be moved to a different sheet without using the clipboard? How can a shape be duplicated to a different sheet without using the clipboard? — Adamarla, Apr 18 '23 at 18:10
@Adamarla By [duplicating](https://learn.microsoft.com/en-us/office/vba/api/excel.shape.duplicate) the [`Shape`](https://learn.microsoft.com/en-us/office/vba/api/excel.shape). — IInspectable, Apr 18 '23 at 18:36

score 3 · Answer 1 · answered Mar 07 '20 at 22:05

Here's an example of just retrying the paste if it fails:

Sub Tester()

    Dim pic, i As Long

    Set pic = Sheet1.Shapes("testPic")

    For i = 1 To 100
        pic.Copy
        PastePicRetry Sheet2.Cells(i, 2)
    Next i

End Sub

'paste problem fix
Sub PastePicRetry(rng As Range)
    Dim i As Long
    Do While i < 20
        On Error Resume Next
        rng.PasteSpecial
        If Err.Number <> 0 Then
            Debug.Print "Paste failed", i
            DoEvents
            i = i + 1
        Else
            Exit Do
        End If
        On Error GoTo 0
        i = i + 1
    Loop
End Sub

score 0 · Answer 2 · edited Oct 02 '21 at 09:03

0

Move your DoEvents to between the copy and paste operation.

edited Oct 02 '21 at 09:03

ouflak

2,458
10
44
49

answered Oct 02 '21 at 07:12

CapnKronic

1
1

Already tried that, didn't work! I don't think anyone has yet been able to successfully solve this clipboard timing issue. – sifar Oct 02 '21 at 07:13
Odd. That’s how I move shapes as a GUI for sheet changes. I draw the objects once and on sheet deactivate I group the shaperange, set left and top to variables and cut. Then on sheet activate I paste. Then if needed, ungroup the selection. I also use a helper function to copy objects from other sheets by name. For that on sheet activate I perform the same actions but with doevents between copy and paste. I have a dozen or so workbooks like this and they work fine. – CapnKronic Oct 04 '21 at 06:03
Can you share your example code or attach a file? – sifar Oct 04 '21 at 06:05
I think copy paste works for you seamlessly because there are 2 sheet events involved that provide some time for copy paste. Try copy pasting in a loop on a single sheet. – sifar Oct 04 '21 at 06:10

Shapes Copy Paste Timing Issue - Excel VBA

2 Answers2

Linked