Word VBA 打开 Excel 文件和更新链接不适用于受保护的视图文件

Question

目标：我有一个 Word 文件，其中包含 275 个链接到 Excel 文件的字段。我希望用户能够选择 Word 文件中的任何范围并更新选定的链接，并且我希望此过程无需为每个单独的链接打开/关闭 Excel 文件。

当前解决方案：当 XL 文件未打开时，Word 的本机链接更新功能非常慢（我可以看到它为每个链接打开/关闭文件），所以我编写了下面的代码来打开文件（如果没有打开）已经打开，然后更新链接。

问题：以下代码非常适用于未在受保护视图中打开的 XL 文件（来自 Internet 位置的文件、电子邮件附件、可能不安全...）。但是如果 XL 文件在受保护的视图中打开，下面的例程会打开/关闭每个链接的 XL 文件，并且速度非常慢。不幸的是，让用户手动执行操作（更改他们的“受保护的视图”安全设置、添加“受信任的位置”等）不是一个可行的选择。

我用以下几行尝试了不同的东西，但没有解决问题。

AppExcel.ProtectedViewWindows.Open Filename:="FilePathName" 
AppExcel.ActiveProtectedViewWindow.Edit

任何建议将不胜感激！非常感谢！

Sub UpdateSelectedLinks()
Dim FilePathName        As String
Dim FileName            As String
Dim Prompt              As String
Dim Title               As String
Dim PromptTime          As Integer
Dim StartTime           As Double
Dim SecondsElapsed      As Double
Dim closeXL             As Boolean
Dim closeSrc            As Boolean
Dim Rng                 As Range
Dim fld                 As Field
Dim AppExcel            As Object
Dim wkb                 As Object

On Error GoTo HandleErr

    StartTime = Timer
    'if elapsed time is > PromptTime, give user prompt saying routine is done
    PromptTime = 5
    Set Rng = Selection.Range

    If Rng.Fields.Count = 0 Then GoTo ExitSub

    On Error Resume Next
    Set AppExcel = GetObject(, "Excel.application") 'gives error 429 if Excel is not open
    If Err.Number = 429 Then
        Err.Clear
        Set AppExcel = CreateObject("Excel.Application")
        closeXL = True
    End If
    On Error GoTo 0

    AppExcel.EnableEvents = False
    AppExcel.DisplayAlerts = False

    FilePathName = ActiveDocument.Variables("SourceXL").Value
    FileName = Mid(FilePathName, InStrRev(FilePathName, "\") + 1)

    '***Updating is much quicker with the workbook open***
    On Error Resume Next
    Set wkb = AppExcel.Workbooks(FileName)
    'error 9 means excel is open, but the source workbook is "out of range", ie. not open
    If Err.Number = 9 Then
        Err.Clear
        Set wkb = AppExcel.Workbooks.Open(FileName:=FilePathName, ReadOnly:=True, UpdateLinks:=False)
        closeSrc = True
    End If
    On Error GoTo 0

    Rng.Fields.Update

    SecondsElapsed = Round(Timer - StartTime, 2)
    If SecondsElapsed > PromptTime Then
        Prompt = "The links have been refreshed."
        Title = "Process Completed"
        MsgBox Prompt, vbInformation, Title
    End If

ExitSub:
   On Error Resume Next
   'close/quit any open objects here
    AppExcel.EnableEvents = True
    AppExcel.DisplayAlerts = True
    If closeSrc Then wkb.Close SaveChanges:=False
    If closeXL Then AppExcel.Quit


    Application.ScreenUpdating = True
    'set all objects to nothing
    Set AppExcel = Nothing
    Set wkb = Nothing
    Set Rng = Nothing
    Set fld = Nothing

Exit Sub

HandleErr:
   'Known errors here
   'Select Case Err.Number
      'Case Is =

      'Resume ExitSub:
   'End Select

   'For unknown errors
   MsgBox "Error: " & Err.Number & ", " & Err.Description

   Resume ExitSub:
End Sub

Answer 1

如果文件已下载，则其他信息保存在区域标识符中。您可以在打开文件之前将其删除。

从这里下载 Streams.zip http://vb.mvps.org/samples/Streams/

然后杀死流

Dim C As New CStreams
dim i as integer

With C
    .FileName = "C:\test.txt"
    For i = 1 To .Count - 1
        Debug.Print .KillStream(i)
    Next
End With