Office 365 VBA复制形状时遇Run-time error '4605'问题求助

我在使用Office 365的Word模板时，通过VBA代码按特定逻辑将内容和形状复制到新Word文档中，执行形状复制粘贴操作时出现错误提示：Run-time error '4605': This method or property is not available because the Clipboard is empty or not valid。相关函数代码如下：

Function AppendShape(bmName As String, Optional fixPosition As Boolean = False) As Boolean
    Dim i As Integer
    Dim pos As Double
    showProgress bmName
    AppendShape = False
    
    pos = DestDoc.Bookmarks("\EndOfDoc").Range.Information(wdVerticalPositionRelativeToPage)
    
    SrcDoc.Activate
' DoEvents
    'SrcDoc.Shapes(bmName).PickUp
    '####################################24/05 Newly added
    If SrcDoc.Bookmarks.Exists(bmName) Then
      SrcDoc.Shapes(bmName).Select
      WrdApp.Selection.Copy
      DestDoc.Activate
      DestDoc.Bookmarks("\EndOfDoc").Select
      'Application.Wait (Now + TimeValue("0:00:3"))
      'DoEvents
      WrdApp.Selection.PasteAndFormat wdPasteDefault
    
      If fixPosition Then
          DestDoc.Shapes(DestDoc.Shapes.count).RelativeVerticalPosition = wdRelativeVerticalPositionPage
          DestDoc.Shapes(DestDoc.Shapes.count).Top = pos + 0
          DestDoc.Shapes(DestDoc.Shapes.count).RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
      End If
      
      AppendShape = True
      DestDoc.Bookmarks("\EndOfDoc").Range.Select
    Else
        AppendShape = False
        Debug.Print "Shape not found: " & bmName
    End If
    DoEvents
End Function

已尝试在复制粘贴前后添加DoEvents，但问题仍未解决。代码在调试时运行正常，推测是时序问题但无法解决。

解决方案 #

1. 绕开剪贴板的直接复制方案（推荐）

剪贴板是问题的核心诱因，直接通过Word对象模型复制形状，完全避免剪贴板依赖：

Function AppendShape(bmName As String, Optional fixPosition As Boolean = False) As Boolean
    Dim srcShape As Shape
    Dim newShape As Shape
    Dim pos As Double
    
    showProgress bmName
    AppendShape = False
    
    ' 先检查书签是否存在
    If Not SrcDoc.Bookmarks.Exists(bmName) Then
        Debug.Print "Shape not found: " & bmName
        Exit Function
    End If
    
    Set srcShape = SrcDoc.Shapes(bmName)
    pos = DestDoc.Bookmarks("\EndOfDoc").Range.Information(wdVerticalPositionRelativeToPage)
    
    ' 直接复制形状到目标文档
    Set newShape = srcShape.Duplicate
    newShape.Cut
    DestDoc.Bookmarks("\EndOfDoc").Range.Paste
    
    ' 如果是图片类形状，也可以用AddPicture直接创建，更稳定
    ' If srcShape.Type = msoPicture Then
    '     Set newShape = DestDoc.Shapes.AddPicture( _
    '         Filename:=srcShape.PictureFormat.Filename, _
    '         LinkToFile:=msoFalse, _
    '         SaveWithDocument:=msoTrue, _
    '         Left:=srcShape.Left, Top:=pos, Width:=srcShape.Width, Height:=srcShape.Height _
    '     )
    '     DestDoc.Bookmarks("\EndOfDoc").Range.InsertParagraphBefore
    ' End If
    
    ' 调整位置逻辑
    If fixPosition Then
        With newShape
            .RelativeVerticalPosition = wdRelativeVerticalPositionPage
            .Top = pos
            .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
        End With
    End If
    
    AppendShape = True
    DestDoc.Bookmarks("\EndOfDoc").Range.Select
End Function

2. 优化剪贴板操作的时序验证

如果必须保留剪贴板操作，增加剪贴板状态检查和等待逻辑，确保复制完成后再粘贴：

Function AppendShape(bmName As String, Optional fixPosition As Boolean = False) As Boolean
    Dim pos As Double
    Dim waitStart As Double
    
    showProgress bmName
    AppendShape = False
    
    If Not SrcDoc.Bookmarks.Exists(bmName) Then
        Debug.Print "Shape not found: " & bmName
        Exit Function
    End If
    
    pos = DestDoc.Bookmarks("\EndOfDoc").Range.Information(wdVerticalPositionRelativeToPage)
    
    ' 直接复制形状，跳过激活和选择操作
    SrcDoc.Shapes(bmName).Copy
    
    ' 等待剪贴板就绪，最多等待5秒
    waitStart = Timer
    Do While Not IsClipboardReady() And Timer < waitStart + 5
        DoEvents
    Loop
    
    ' 确认剪贴板有内容再粘贴
    If IsClipboardReady() Then
        DestDoc.Bookmarks("\EndOfDoc").Range.PasteAndFormat wdPasteDefault
        
        If fixPosition Then
            With DestDoc.Shapes(DestDoc.Shapes.Count)
                .RelativeVerticalPosition = wdRelativeVerticalPositionPage
                .Top = pos
                .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
            End With
        End If
        
        AppendShape = True
        DestDoc.Bookmarks("\EndOfDoc").Range.Select
    Else
        Debug.Print "Clipboard failed to load shape data: " & bmName
    End If
End Function

' 辅助函数：检查剪贴板是否有效
Function IsClipboardReady() As Boolean
    On Error Resume Next
    ' 尝试读取剪贴板文本判断状态
    IsClipboardReady = Not IsEmpty(Clipboard.GetText)
    On Error GoTo 0
End Function

3. 移除不必要的界面操作

原代码中频繁的Activate和Select会干扰Word的内部时序，尽量直接操作对象而非依赖界面状态：

• 删除SrcDoc.Activate和DestDoc.Activate语句
• 用Range.PasteAndFormat代替Selection.PasteAndFormat，避免依赖选中状态

核心原因说明 #

调试时运行正常是因为单步执行给了剪贴板足够的处理时间，批量运行时Word内部线程调度导致剪贴板还未完成数据写入就执行了粘贴操作。绕开剪贴板的方案从根源避免了这类时序问题，是最稳定的解决方式。

内容的提问来源于stack exchange，提问作者sha