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

Question

我正在尝试在 Word 中创建一个 Excel 对象，该对象反映 Excel 中数据的实时更新。

我的用例是在将 Word 和 Excel 两个文件发送给某人时动态更新对象路径，并且链接不应中断。

我找到了适用于本地驱动器的代码。

Option Explicit

' Word macro to automatically update field links to other files
' Created by Paul Edstein (aka macropod). Posted at:
' http://windowssecrets.com/forums/showthread.php/154379-Word-Fields-and-Relative-Paths-to-External-Files
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 bracnhes 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

Answer 1

大多数 Office 应用程序的对象模型仅设计用于处理本地文件。无论如何，当将文件放入网络共享并从那里打开它们时，它们可以在本地复制，而其他文件仍然驻留在网络共享上（如果未打开）。请参阅从网络驱动器打开的文件\本地复制的共享吗？了解更多信息。