Update Hyperlink for each word doc

Hidayat · #1 12-22-2021, 07:32 PM

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

gmayor · #2 12-22-2021, 11:29 PM

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

Code:

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 · #3 12-23-2021, 12:11 AM

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?

Code:

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

Updated code:

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Entering text next to hyperlink copies the hyperlink style	abeneschan	Word	0	07-23-2018 02:36 PM
Hyperlink: open the document only once, quit & reopen PP, hyperlink doesnt work anymore	quanghuynguyenhua	PowerPoint	0	10-10-2015 06:17 PM
Hyperlink Format varies, depending on whether Target file was saved or unsaved on Hyperlink Copy	RichardDavey	Word	0	05-26-2015 05:26 PM
Insert the Hyperlink and hide all sheets except clicking Hyperlink	PRADEEPB270	Excel	1	02-22-2013 09:47 AM
[Word 2007] How to hyperlink directly another word file chapter/paragraph/bookmark?	LeeFX	Word	4	05-05-2011 05:53 PM