VBA to edit hyperlinks in word document

[grimsbymatt]

Hi,

I have written a VBA routine to step through each hyperlink in a document and edit them according to a re-structuring of our network drive.

However, after I have run the VBA on a document (luckily just test documents so far), Word seems to crash when trying to open it. Furthermore, even if I replace the document with a (supposedly) unaffected copy, it still takes a long time to open, as though Word is remembering that the document that did have that path and filename had a problem.

Any ideas, anyone?

[lucas]

Please post at least the code....

[grimsbymatt]

Sub updHLinks()
Dim word_app As Word.Application
Dim word_doc As Word.Document
Dim doc_story As Word.Range
Dim hyper_link As Word.Hyperlink
Dim file As String

' Make a Word server object.
Set word_app = New Word.Application
word_app.Visible = False
' Open the Document.
file = WordApplicationGetOpenFileName("*.doc", True, True)
Set word_doc = Word.Documents.Open(file)


' Loop over all document stories.
For Each doc_story In word_doc.StoryRanges
For Each hyper_link In doc_story.Hyperlinks

If InStr(hyper_link.Address, "/tdc/") > 0 Then
hyper_link.Address = remTDC(hyper_link.Address)
End If

If InStr(hyper_link.TextToDisplay, "/tdc/") > 0 Then
hyper_link.TextToDisplay = remTDC(hyper_link.TextToDisplay)
End If

If InStr(hyper_link.ScreenTip, "/tdc/") > 0 Then
hyper_link.ScreenTip = remTDC(hyper_link.ScreenTip)
End If
Next
Next doc_story

End Sub

Private Function remTDC(inpStr As String) As String
Dim point As Integer
point = InStr(inpStr, "/tdc/")

If point > 0 Then
inpStr = Left(inpStr, point) & Mid(inpStr, point + 5, Len(inpStr) - point - 5 + 1)
End If

remTDC = inpStr

End Function
Function WordApplicationGetOpenFileName(FileFilter As String, ReturnPath As Boolean, ReturnFile As Boolean) As String
' returns the folder and/or filename to a single user selected file
Dim strFileName As String, strPathName As String
If Not ReturnPath And Not ReturnFile Then Exit Function
If FileFilter = "" Then FileFilter = "*.*"
With Application.Dialogs(wdDialogFileOpen)
.Name = FileFilter
On Error GoTo MultipleFilesSelected
If .Display = -1 Then
strFileName = .Name
End If
On Error GoTo 0
End With
On Error GoTo 0
' remove any "-characters
If InStr(1, strFileName, " ", vbTextCompare) > 0 Then
strFileName = Mid$(strFileName, 2, Len(strFileName) - 2)
End If
If ReturnPath Then
strPathName = CurDir & Application.PathSeparator
Else
strPathName = ""
End If
If Not ReturnFile Then strFileName = ""
WordApplicationGetOpenFileName = strPathName & strFileName
MultipleFilesSelected:
End Function