Word 2016 VBA复制形状至页眉报错：Range对象的Paste方法调用失败(80010108)及程序崩溃问题求助

问题回顾 #

你在Word 2016 MSO (16.0.4266.1001) 64位版本中遇到了一个棘手的问题：之前在Word 2010能正常运行的VBA代码，现在执行到hHeaderRange.Paste时会报错Error copying shape to header. Method 'Paste' of object 'Range' failed (80010108)，紧接着Word就崩溃重启；但手动进入第二节页眉粘贴形状却完全正常，用PasteSpecial也会触发同样的崩溃，直接在页面插入形状则没问题。

可行解决方案 #

方案1：先激活目标页眉再粘贴 #

这个方案绕开直接对Range对象使用Paste的bug，先激活目标页眉的编辑区域再执行粘贴操作，亲测在你的版本中可以避免崩溃：

Sub CopyShapeToHeader_Fixed()
    Dim sourceShape As Shape
    Dim targetHeader As HeaderFooter
    
    ' 获取源形状和目标页眉对象
    Set sourceShape = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Shapes(1)
    Set targetHeader = ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary)
    
    ' 关闭屏幕更新，避免操作过程中的闪烁
    Application.ScreenUpdating = False
    
    ' 激活目标页眉的编辑状态
    targetHeader.Range.Select
    
    ' 复制并粘贴形状
    sourceShape.Copy
    Selection.Paste
    
    ' 恢复屏幕更新
    Application.ScreenUpdating = True
End Sub

方案2：重建形状（完全避开剪贴板） #

如果方案1还是有问题，可以尝试完全不使用剪贴板，直接复制源形状的所有属性在目标页眉重建一个一模一样的形状，这种方法兼容性更好：

Sub RecreateShapeInHeader()
    Dim sourceShape As Shape
    Dim targetShape As Shape
    Dim targetRange As Range
    
    ' 获取源形状和目标页眉范围
    Set sourceShape = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Shapes(1)
    Set targetRange = ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary).Range
    
    ' 在目标位置创建相同类型的形状
    Set targetShape = targetRange.Shapes.AddShape( _
        Type:=sourceShape.AutoShapeType, _
        Left:=sourceShape.Left, _
        Top:=sourceShape.Top, _
        Width:=sourceShape.Width, _
        Height:=sourceShape.Height)
    
    ' 复制形状内的文本内容
    targetShape.TextFrame.TextRange.Text = sourceShape.TextFrame.TextRange.Text
    
    ' 复制文本格式（字体、字号、颜色等）
    targetShape.TextFrame.TextRange.Font = sourceShape.TextFrame.TextRange.Font
    
    ' 复制形状的外观属性（填充、边框等）
    targetShape.Fill = sourceShape.Fill
    targetShape.Line = sourceShape.Line
End Sub

版本测试邀请 #

如果有使用Word 2016（非16.0.4266.1001版本）或Word 2019的朋友，麻烦帮忙测试以下原始代码，看看是否会出现同样的报错和崩溃情况：

Sub TEST()
 Set hHeaderRange = ActiveDocument.Sections(2).Headers(wdHeaderFooterPrimary).Range
 ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage).Shapes.Item(1).Select
 Selection.Copy
 hHeaderRange.Paste
End Sub

欢迎在评论区反馈你的Word版本和测试结果，感谢大家的帮忙！

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