使用VBA将Word文档形状复制到另一文档及复制偶发失效问题排查

问题原因 #

• 核心问题是过度依赖Selection对象：刚打开的文档未渲染对应章节内容时，代码执行的选中操作未被Word UI线程确认，Selection.Copy无法将内容写入剪贴板，只有提前打开文档、光标在对应区域时，选中状态才会被正确识别。
• VBA执行速度快于Word剪贴板响应速度，复制后立即切换文档粘贴，剪贴板还未完成写入就触发粘贴，导致为空。
• 频繁切换激活文档增加UI线程负担，进一步放大操作的不稳定性。
• 范围调整时End:=MyRange.End - 1可能截断绘图画布的锚点，导致ShapeRange引用不稳定。

修复方案 #

尽量避免使用Selection对象，直接调用形状自身的Copy方法，添加DoEvents让Word完成后台操作，减少不必要的文档激活操作，修复后的代码如下：

Sub CopyInfo()
  Dim A_Path As String
  Dim dlgSelectFile As FileDialog
  Set dlgSelectFile = Application.FileDialog(msoFileDialogFilePicker)
  With dlgSelectFile
    .Filters.Clear
    .AllowMultiSelect = False
    If .Show <> -1 Then Exit Sub ' 处理用户取消选择的情况
    A_Path = .SelectedItems(1)
  End With

  Dim ADoc As Document
  ' 运行不稳定可以把Visible参数改为True，让文档前台打开完成渲染
  Set ADoc = Documents.Open(A_Path, Visible:=False)
  Dim MyRange As Range
  Dim findRng As Range
  Set findRng = ADoc.Content
  
  ' 定位目标标题章节
  With findRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "Logical Description"
    .Style = "Heading 2"
    .Format = True
    .Forward = True
    .MatchCase = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Execute
  End With

  If findRng.Find.Found = True Then
    ' 获取标题所属完整章节范围
    Set MyRange = findRng.Duplicate.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
    MyRange.Start = MyRange.Paragraphs.First.Range.End ' 跳过标题本身
    
    Dim targetBkmk As Range
    Set targetBkmk = ThisDocument.Bookmarks("StateDiagram").Range ' 提前获取B文档的粘贴目标位置
    
    ' 倒序遍历形状，直接调用Copy方法无需选中
    Dim i As Long
    For i = MyRange.ShapeRange.Count To 1 Step -1
      MyRange.ShapeRange.Item(i).Copy
      DoEvents ' 等待剪贴板写入完成
      ' 直接粘贴到目标位置，无需切换激活文档
      targetBkmk.PasteSpecial Placement:=wdInLine
      DoEvents ' 等待粘贴完成
    Next i
  End If
  ADoc.Close SaveChanges:=wdDoNotSaveChanges ' 处理完自动关闭A文档，不需要可删除
End Sub

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