Update Hyperlink for each word doc

[Hidayat]

Hi all,



I am trying to update hyperlink bookmarks for each word document in a folder.

Found a similar post here but find and replace doesn't work in my case.
Using this related code, I modified to find and replace all hyperlinks in the word doc but it seems no hyperlink has been updated in the new file when macro is run.
Secondly, not sure if it is possible to save as current file instead of output as new file.

Appreciate if you could share similar resource or help to review my code.


Thanks in advance!

Regards
Hidayat

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strInFolder As String, strOutFold As String, strFile As String, wdDoc As Document
strInFolder = GetFolder
If strInFolder = "" Then Exit Sub
strFile = Dir(strInFolder & "\*.doc*", vbNormal)

'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFolder & "\Output\"

'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFolder & "\*.doc*", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
  
  With wdDoc
    ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
    Selection.Find.Replacement.ClearFormatting
    
      With Selection.Find

    'Old hyperlink
        .Text = _
            "www.yahoo.com"
    'New Hyperlink
        .Replacement.Text = _
            "www.google.com"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .CorrectHangulEndings = True
        .HanjaPhoneticHangul = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
        End With
        
       'Save and close the document
    .SaveAs FileName:=strOutFold & .Name, AddToRecentFiles:=False
    .Close
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

[gmayor]

That's not going to work ... as you have found. Try the following instead.

Sub UpdateDocuments()
Dim strInFolder As String, strOutFold As String, strFile As String
Dim wdDoc As Document
Dim hLink As Hyperlink
Dim sAddress As String, sDisplay As String, sTip As String

    Application.ScreenUpdating = False
    strInFolder = GetFolder
    If strInFolder = "" Then Exit Sub
    strFile = Dir(strInFolder & "\*.doc*", vbNormal)

    'Check for documents in the folder - exit if none found
    If strFile <> "" Then strOutFold = strInFolder & "\Output\"

    'Test for an existing outpfolder & create one if it doesn't already exist
    If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
    strFile = Dir(strInFolder & "\*.doc*", vbNormal)
    While strFile <> ""
        Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)

        For Each hLink In wdDoc.Hyperlinks
            With hLink
                sAddress = .Address
                If InStr(1, LCase(sAddress), "www.yahoo.com") > 0 Then
                    .Target = Replace(LCase(.Target), "www.yahoo.com", "www.google.com")
                    .Address = Replace(LCase(.Address), "www.yahoo.com", "www.google.com")
                    .TextToDisplay = Replace(LCase(.TextToDisplay), "www.yahoo.com", "www.google.com")
                    .ScreenTip = "Click to search"
                End If
            End With
        Next hLink
    Next hLink

    'Save and close the document
    wdDoc.SaveAs FileName:=strOutFold & wdDoc.Name, AddToRecentFiles:=False
    wdDoc.Close
    strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub

[Hidayat]

Thank you Graham!!

I was manage to use the code and with some vba recording fit into my requirements.

Another issue came up, is there a way to reference the current selected open file as the current active window so that it runs in the background, visible = false?

Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)

Updated code:

Sub Find_Replace_FilesInFolder()

Application.ScreenUpdating = False

Dim strInFolder As String, strOutFold As String, strFile As String, wdDoc As Document
strInFolder = GetFolder
If strInFolder = "" Then Exit Sub
strFile = Dir(strInFolder & "\*.doc*", vbNormal)

'Check for documents in the folder - exit if none found
If strFile <> "" Then strOutFold = strInFolder & "\Output\"

'Test for an existing outpfolder & create one if it doesn't already exist
If Dir(strOutFold, vbDirectory) = "" Then MkDir strOutFold
strFile = Dir(strInFolder & "\*.doc*", vbNormal)
While strFile <> ""
  Set wdDoc = Documents.Open(FileName:=strInFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=True)
  
  With wdDoc
    With Selection.Find
    ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
    Selection.Find.Replacement.ClearFormatting

    'Old hyperlink
        .Text = _
            "www.yahoo.com"
    'New Hyperlink
        .Replacement.Text = _
            "www.google.com"
        .Forward = True
        End With
        
        Selection.Find.Execute Replace:=wdReplaceAll
        ActiveWindow.View.ShowFieldCodes = Not ActiveWindow.View.ShowFieldCodes
        Selection.WholeStory
        Selection.Fields.Update
        
       'Save and close the document
    .SaveAs FileName:=strOutFold & .Name, AddToRecentFiles:=False
    .Close
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function