对象“Shape”的“复制”方法失败：运行时错误“-2147221040 (800401d0)”

Question

我正在尝试在两个工作表之间复制并粘贴形状。

ws1.Shapes(1).Copy
ws2.Paste

它在

.Copy

行失败并出现错误。

对象“Shape”的方法“复制”失败：运行时错误“-2147221040 (800401d0)”

我在 MS 文档中找不到任何参考。

Answer 1

也遇到过同样的问题。迄今为止，没有任何明显的规律或理由。 即随机选择和复制形状的代码失败并报告错误消息。

能够缩小某些方面的范围：
a) 似乎只发生在带有 Office 365 的 Windows 10 中（其他系统，没有问题）
b) 如果用户重新启动系统并再次运行相同的代码，一切正常。

编辑： 经过进一步的测试和研究，得出的结论是 Excel 中完全随机的故障。
GWteB 在 Mr Excel 上也得出了同样的结论（由于广告饱和，链接被删除）。 那里提出的概念解决了部分问题。然而，在那里他们只经历了粘贴失败。然而我见过复制和粘贴失败的情况。

我已经实现了一个功能（扩展了 GWteB 的思想）：

Private Function TransferShape(stMT$, ByVal spSp As Shape, ByVal rgSpTarget As Range) As Integer

    Dim inAttempts%, inMaxAttempts%, inErrType%

''' Selection here assumes paste to target range is in the Active sheet
    rgSpTarget.Select 

procRetry: inAttempts = 0: inMaxAttempts = 100
        
    Do: inErrType = 0
    
    ''' Yield to OS occasionally
        If inAttempts Mod 20 = 0 Then DoEvents

    ''' With local error handling: Attempt the copy and paste
    ''' Note: Recording failed to copy as error type 601, and failed to paste as error type 602
    '''       Though not currently acting any differently based on type
        On Error Resume Next: Err.Clear: spSp.Copy
        If Err <> 0 Then
            inErrType = 601
        Else
            ActiveSheet.Paste
            If Err <> 0 Then inErrType = 602
        End If
        On Error GoTo 0
    
    ''' No error type: Exit Do now (all done)
        If inErrType = 0 Then Exit Do
            
    ''' Attempt failed: Increment attempts and try again (until Max Attempts reached).
        inAttempts = inAttempts + 1
    Loop Until inAttempts = inMaxAttempts
    
''' Failed: Prompt user to keep trying or not
    If inErrType Then
        If MsgBox(Buttons:=69, Title:=stMT, Prompt:= _
            "Attempting to copy and paste a picture failed " & inMaxAttempts & " times." & vbLf & vbLf & _
            "Shall we try again?") = vbRetry Then GoTo procRetry
    End If

''' DONE: Clear local objects and return Error Type (if any)
    Set spSp = Nothing: Set rgSpTarget = Nothing: TransferShape = inErrType

End Function

实施上述操作后，所有形状复制和粘贴失败都停止了。
有趣的是，也没有看到达到最大尝试次数。但进一步测试需要改天再进行。