Word VBAでExcelファイルを開き、保護されたビューファイルで動作しないリンクを更新する

Question

目的：275個のリンクされたフィールドを持つWordファイルがExcelファイルにあります。ユーザーがWordファイル内の任意の範囲を選択して選択したリンクを更新できるようにしたいと思います。個々のリンクのExcelファイルの開閉を行わずにこのプロセスを実行したいと思います。

現在の解決策：XLファイルが開いていないとWordのネイティブリンクの更新機能が非常に遅いです（リンクごとにファイルを開いたり閉じているのがわかります）ので、ファイルを開くには以下のコードを書いていますまだ開いていない場合は、リンクを更新します。

問題：以下のコードは、保護されたビューで開かないXLファイル（インターネットの場所から送信されたファイル、電子メールの添付ファイル、安全でない可能性があります...）に適しています。しかし、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

ファイルがダウンロードされた場合のTher情報は、ゾーン識別子に保存されます。ファイルを開く前に削除することができます。

ダウンロード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