VBA中OLEObject缺失Attachment Label：嵌入文件仅首个显示标签

我尝试用VBA在Word文档中嵌入两个Excel文件，但只有第一个嵌入的文件能在文档里显示标签。单独运行第二个文件的嵌入代码时，标签显示正常。不确定代码里是不是漏了什么配置，想要实现两个附件都显示标签，相关代码如下：

Sub Attach_REL_BUS_Extract_To_Word()
    'Declare Word Variables
    Dim WrdApp, WrdDoc

    Dim strdocname
    On Error Resume Next

    'Declare Excel Variables
    Dim WrkSht
    Dim Rng
    
    ' Define paths to Excel and Word files
    wordFilePath = "D:\GIT\modules\core\bin\logs\Test.docx"

    ' Create Excel and Word objects
    Set objExcel = CreateObject("Excel.Application")

    'Create a new instance of Word
    Set WrdApp = CreateObject("Word.Application")
        WrdApp.Visible = False
        WrdApp.Activate
     
    
    'Open existing word document
     Set WrdDoc = WrdApp.Documents.Open(wordFilePath)

   
    Const ClassType = "Excel.Sheet.12"
    Const DisplayAsIcon = True
    Const IconFileName = "C:\WINDOWS\Installer\{90160000-000F-0000-1000-0000000FF1CE}\xlicons.exe"
    Const IconIndex = 1
    Const LinkToFile = False
    Const relFilename = "D:\GIT\modules\core\src\main\resources\config\relCount.xlsx"
    const relIconLabel="Rel Count Extract"
    Const busFilename = "D:\GIT\modules\core\src\main\resources\config\busCount.xlsx"
    const busIconLabel="Bus Count Extract"

   
    
    Set WrdRng1 = WrdDoc.Bookmarks("s_Bus_Count_Attachment").Range

    With WrdRng1
        set newole = .InlineShapes.AddOLEObject( ClassType, busFilename, LinkToFile, DisplayAsIcon, IconFileName, IconIndex, busIconLabel)
        With newole
           .Height = 80
           .Width = 140
        End With
    End With       
    
    Set WrdRng = WrdDoc.Bookmarks("s_Rel_Count_Attachment").Range

    With WrdRng
        set newole = .InlineShapes.AddOLEObject( ClassType, relFilename, LinkToFile, DisplayAsIcon, IconFileName, IconIndex, relIconLabel)
        With newole
           .Height = 80
           .Width = 140
        End With
    End With       

    
    
    WrdDoc.SaveAs wordFilePath
    objExcel.Quit
    WrdApp.Quit
    Set objExcel = Nothing
    Set WrdApp = Nothing


End Sub
Attach_REL_BUS_Extract_To_Word()

WScript.Quit

问题原因及修复方案 #

问题出在书签范围被覆盖：在第一个书签位置插入OLE对象后，原书签会被自动删除（插入内容会替换书签所在的范围），导致第二个代码无法找到完整的书签定位，最终标签渲染异常。

修改后的代码：

Sub Attach_REL_BUS_Extract_To_Word()
    'Declare Word Variables
    Dim WrdApp, WrdDoc
    Dim strdocname
    On Error Resume Next

    'Declare Excel Variables
    Dim WrkSht
    Dim Rng
    
    ' Define paths to Excel and Word files
    wordFilePath = "D:\GIT\modules\core\bin\logs\Test.docx"

    ' Create Excel and Word objects
    Set objExcel = CreateObject("Excel.Application")

    'Create a new instance of Word
    Set WrdApp = CreateObject("Word.Application")
    WrdApp.Visible = False
    WrdApp.Activate
    
    'Open existing word document
    Set WrdDoc = WrdApp.Documents.Open(wordFilePath)

    Const ClassType = "Excel.Sheet.12"
    Const DisplayAsIcon = True
    Const IconFileName = "C:\WINDOWS\Installer\{90160000-000F-0000-1000-0000000FF1CE}\xlicons.exe"
    Const IconIndex = 1
    Const LinkToFile = False
    Const relFilename = "D:\GIT\modules\core\src\main\resources\config\relCount.xlsx"
    Const relIconLabel="Rel Count Extract"
    Const busFilename = "D:\GIT\modules\core\src\main\resources\config\busCount.xlsx"
    Const busIconLabel="Bus Count Extract"

    '处理第一个嵌入：复制书签范围，避免原书签被删除
    Dim busRng
    Set busRng = WrdDoc.Bookmarks("s_Bus_Count_Attachment").Range.Duplicate
    With busRng
        Set newole = .InlineShapes.AddOLEObject(ClassType, busFilename, LinkToFile, DisplayAsIcon, IconFileName, IconIndex, busIconLabel)
        With newole
           .Height = 80
           .Width = 140
        End With
    End With       
    
    '处理第二个嵌入：同样复制书签范围
    Dim relRng
    Set relRng = WrdDoc.Bookmarks("s_Rel_Count_Attachment").Range.Duplicate
    With relRng
        Set newole = .InlineShapes.AddOLEObject(ClassType, relFilename, LinkToFile, DisplayAsIcon, IconFileName, IconIndex, relIconLabel)
        With newole
           .Height = 80
           .Width = 140
        End With
    End With       

    WrdDoc.SaveAs wordFilePath
    objExcel.Quit
    WrdApp.Quit
    Set objExcel = Nothing
    Set WrdApp = Nothing
End Sub
Attach_REL_BUS_Extract_To_Word()
WScript.Quit

关键修改点 #

• 使用.Range.Duplicate复制书签的范围对象，插入OLE对象时不会破坏原书签，确保第二个书签能被正常定位
• 清理了无意义的空行和注释，代码结构更清晰

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