使用Word VBA动态更新网络驱动器中的Excel对象文件路径

需求是在Word中插入可实时同步Excel数据的对象，当Word与Excel文件一同发送给他人时，链接路径能自动适配新位置，避免失效。目前遇到两个问题：

• 找到的适用于本地驱动器的VBA代码，在网络驱动器运行时会出现持续加载的情况，无法正常执行。
• 修改后的手动触发代码可以更新链接，但会重复创建链接对象，导致程序陷入循环。

本地可用代码 #

Option Explicit

' Word macro to automatically update field links to other files
' Created by Paul Edstein (aka macropod)
Dim TrkStatus As Boolean      ' Track Changes flag
Dim Pwd As String ' String variable to hold passwords for protected documents
Dim pState As Boolean ' Document protection state flag

Sub AutoOpen()
' This routine runs whenever the document is opened.
' It calls on the others to do the real work.
'
' Prepare the environment.
With ActiveDocument
    ' Insert your document's password between the double quotes on the next line
    Pwd = ""
    ' Initialise the protection state
    pState = False
    ' If the document is protected, unprotect it
    If .ProtectionType <> wdNoProtection Then
        ' Update the protection state
        pState = True
        ' Unprotect the document
        .Unprotect Pwd
    End If
    Call MacroEntry
    ' Most of the work is done by this routine.
    Call UpdateFields
    ' Go to the start of the document
    Selection.HomeKey Unit:=wdStory
    ' Clean up and exit.
    Call MacroExit
    ' If the document was protected, reprotect it, preserving any formfield contents
    If pState = True Then .Protect wdAllowOnlyFormFields, Noreset:=True, Password:=Pwd
    ' Set the saved status of the document to true, so that changes via
    ' this code are ignored. Since the same changes will be made the
    ' next time the document is opened, saving them doesn't matter.
    .Saved = True
End With
End Sub

Private Sub MacroEntry()
' Store current Track Changes status, then switch off temporarily.
With ActiveDocument
    TrkStatus = .TrackRevisions
    .TrackRevisions = False
End With
' Turn Off Screen Updating temporarily.
Application.ScreenUpdating = False
End Sub

Private Sub MacroExit()
' Restore original Track Changes status
ActiveDocument.TrackRevisions = TrkStatus
' Restore Screen Updating
Application.ScreenUpdating = True
End Sub

Private Sub UpdateFields()
' This routine sets the new path for external links, pointing them to the current folder.
Dim Rng As Range, Fld As Field, Shp As shape, iShp As InlineShape, i As Long
Dim OldPath As String, NewPath As String, Parent As String, Child As String, StrTmp As String
' Set the new path.
' If your files are always in a folder whose path branches off, one or more levels above the current
' folder, replace the second '0' on the next line with the number of levels above the current folder.
For i = 0 To UBound(Split(ActiveDocument.Path, "\")) - 0
  Parent = Parent & Split(ActiveDocument.Path, "\")(i) & "\"
Next i
' If your files are in a Child folder below the (new) parent folder, add the Child folder's
' path from the parent (minus the leading & trailing "\" path separators) on the next line.
Child = ""
NewPath = Parent & Child
' Strip off any trailing path separators.
While Right(NewPath, 1) = "\"
  NewPath = Left(NewPath, Len(NewPath) - 1)
Wend
NewPath = NewPath & "\"
' Go through all story ranges in the document.
With ThisDocument
  For Each Rng In .StoryRanges
    ' Go through the shapes in the story range.
    For Each Shp In Rng.ShapeRange
      With Shp
        ' Skip over shapes that don't have links to external files.
        If Not .LinkFormat Is Nothing Then
          With .LinkFormat
            OldPath = Left(.SourceFullName, InStrRev(.SourceFullName, "\"))
            ' Replace the link to the external file if it differs.
            If OldPath <> NewPath Then
              .SourceFullName = Replace(.SourceFullName, OldPath, NewPath)
              On Error Resume Next
              .AutoUpdate = False
              On Error GoTo 0
            End If
          End With
        End If
      End With
    Next Shp
    ' Go through the inlineshapes in the story range.
    For Each iShp In Rng.InlineShapes
      With iShp
        ' Skip over inlineshapes that don't have links to external files.
        If Not .LinkFormat Is Nothing Then
          With .LinkFormat
            OldPath = Left(.SourceFullName, InStrRev(.SourceFullName, "\"))
            ' Replace the link to the external file if it differs.
            If OldPath <> NewPath Then
              .SourceFullName = Replace(.SourceFullName, OldPath, NewPath)
              On Error Resume Next
              .AutoUpdate = False
              On Error GoTo 0
            End If
          End With
        End If
      End With
    Next iShp
    ' Go through the fields in the story range.
    For Each Fld In Rng.Fields
      With Fld
        ' Skip over fields that don't have links to external files.
        If Not .LinkFormat Is Nothing Then
          With .LinkFormat
            OldPath = Left(.SourceFullName, InStrRev(.SourceFullName, "\"))
            ' Replace the link to the external file if it differs.
            If OldPath <> NewPath Then
              .SourceFullName = Replace(.SourceFullName, OldPath, NewPath)
              On Error Resume Next
              .AutoUpdate = False
              On Error GoTo 0
            End If
          End With
        End If
      End With
    Next Fld
  Next Rng
  .Save
End With
End Sub

修改后的手动触发代码 #

Option Explicit

Sub UpdateLinksManual()
    On Error GoTo ErrorHandler

    Dim doc As Document
    Set doc = ActiveDocument

    ' Call the main routine to update links
    UpdateLinks doc

    ' Save the document
    doc.Save

Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Description
End Sub

Sub UpdateLinks(doc As Document)
    On Error GoTo ErrorHandler

    Dim newPath As String
    newPath = doc.Path & "\"

    ' Update shapes
    Dim shapesCopy As Shapes
    Set shapesCopy = doc.Shapes.Duplicate ' Create a copy to avoid modification during iteration
    For Each shp In shapesCopy
        UpdateLinkFormat shp.LinkFormat, newPath
    Next shp

    ' Update inline shapes
    ' ... (similar approach for inline shapes and fields)

Exit Sub

ErrorHandler:
    MsgBox "Error: " & Err.Description
End Sub

Sub UpdateLinkFormat(LinkFmt As Object, NewPath As String)
    If Not LinkFmt Is Nothing Then
        Dim oldPath As String
        oldPath = Left(LinkFmt.SourceFullName, InStrRev(LinkFmt.SourceFullName, "\"))

        If oldPath <> NewPath Then
            LinkFmt.SourceFullName = Replace(LinkFmt.SourceFullName, OldPath, NewPath)
            LinkFmt.AutoUpdate = False
        End If
    End If
End Sub

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