形状复制粘贴时间问题 - Excel VBA答案

【问题标题】：Shapes Copy Paste Timing Issue - Excel VBA形状复制粘贴时间问题 - Excel VBA
【发布时间】：2020-03-07 16:20:54
【问题描述】：

我使用的是 Windows 10 Enterprise 64 位、Office 2016 Pro 64 位。我正在尝试将 2 个形状从一个工作表复制到另一个工作表。

以下 API 代码有时有效，但大多数情况下它会为复制或粘贴（剪贴板计时问题）拍摄错误 1004。我尝试过使用不同的解决方案，例如计时器、等待、API 等，但大多数时候看起来很慢而且有问题！我也试图将图像粘贴到每个合并单元格的两端。我还附上了a sample file 供检查。

我不记得了，但我在某处读到，如果我创建单独的复制和粘贴功能/程序，那么它可能会解决问题，但不确定！

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

API 代码：

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

编辑：

@iinspectable，这不是一个正常的复制粘贴问题，而是一个剪贴板时间问题，如果复制粘贴涉及一个循环，即复制粘贴多次。这是SingleCopyPaste 过程有效但MultipleCopyPaste 过程无效的示例。我希望你现在明白我的意思。

选项显式

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

【问题讨论】：

显而易见的问题是：你为什么（ab）为此使用剪贴板？
因为复制粘贴剪贴板时间问题。
既然这没有通过，让我改写问题：为什么不直接复制对象，而不依赖系统的剪贴板（属于用户，而不是你）？
我之前是这样做的，但是由于我无法正确复制粘贴，因此不得不求助于 WinAPI 在复制粘贴之间暂停。希望这很清楚。
不，不是。您正在尝试将对象从一个工作表复制到另一个工作表。这不是需要剪贴板的操作。如果您正在使用剪贴板，因为一些未公开的代码“不起作用”，那么也许您应该尝试修复该代码。

标签： excel vba winapi clipboard shapes

【解决方案1】：

这是一个在粘贴失败时重试粘贴的示例：

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

【讨论】：

【解决方案2】：

将您的DoEvents 移动到复制和粘贴操作之间。

【讨论】：

已经试过了，没用！我认为还没有人能够成功解决这个剪贴板计时问题。
奇数。这就是我将形状作为图形用户界面移动以进行工作表更改的方式。我绘制对象一次并在工作表上停用我对 shaperange 进行分组，将 left 和 top 设置为变量并剪切。然后在工作表上激活我粘贴。然后，如果需要，取消组合选择。我还使用辅助函数按名称从其他工作表中复制对象。对于工作表上的激活，我执行相同的操作，但在复制和粘贴之间使用 doevents。我有十几本这样的工作簿，它们都很好用。
您能分享您的示例代码或附加文件吗？
我认为复制粘贴可以无缝地为您工作，因为涉及 2 个工作表事件，为复制粘贴提供了一些时间。尝试在单张纸上循环复制粘贴。