View Single Post
 
Old 12-22-2021, 07:32 PM
Hidayat Hidayat is offline Windows 10 Office 2016
Novice
 
Join Date: Dec 2021
Posts: 2
Hidayat is on a distinguished road
Default Update Hyperlink for each word doc

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

Code:
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
Reply With Quote