Use Word VBA to find, delete and insert duplicate hyperlinks

marceepoo · #1 12-29-2016, 07:08 PM

I am a public interest lawyer, trying to use a little VBA so that two people who have the same document in a shared Dropbox directory can insert hyperlinks pointing to PDF files, on a list of exhibits in a Microsoft Word document.

Could someone please show me how to remove the existing hyperlink, and create a new one that is attached only to the second word on the line, pointing to the same address (URL)?

As I said, the hyperlinks are attached to items on the list. A santized version of the Word document appears below.

Each list item is: (i) several words long, (ii) is on a separate line, and (iii) is formatted with numbered style Heading 1.

Many of the list items contain a single hyperlink somewhere on the line, and sometimes the hyperlink covers the entire line.

There is only one hyperlink on each line, since each list item is a description of a single PDF file.

Each hyperlink points to the address of a PDF file on a workstation using Dropbox, where the “master directory” is "C:\Users\Harvey\Dropbox\Kazoti James", and the address of each PDF is under that “master directory”.

Obviously, the workstation user is named Harvey.

I want to remove those hyperlinks and create a new identical hyperlink that is attached only to the second word on the line.

Then I want to insert similar hyperlinks so that Person #2 (“ José”), who also uses Dropbox on his workstation, will have hyperlinks that point to identical PDF files that appear on his workstation.

In other words, I want to create a modified hyperlink for José, whose master directory is “E:\DropBoxSycDir\Dropbox\ Kajota James”.

The rest of the PDF's address is identical. For example, the following two URLs point to the same file: Harvey: "C:\Users\Harvey\Dropbox\Kazoti James\scans\Deed to home.pdf" Jose: "E:\DropBoxSycDir\Dropbox\ Kajota James\scans\Deed to home.pdf"

I used the code below to find hyperlinks in Section 5 of the document (where the list of exhibits is found).

I recognize that my code does not limit the search to section 5, nor to paragraphs having the numbered style Heading 1, but that does not matter since I removed all hyperlinks from everywhere else in the document to facilitate this search.

Could someone please show me how to remove the existing hyperlink, and create a new one that is attached only to the second word on the line? That will give me enough information so that I will be able to insert a hyperlink for Jose, attached to the 3d word on the line.

Thanks,

Marc

Code:

Sub subFindNdRemovHyprlnksAndInsert2NewLinks()
    Dim doc As Document

    Dim i, x As Long
    Dim strHyperlinkURL As String
    Dim strHyperlinkParaText As String
    Dim oRng As Range

    Set oRng = ActiveDocument

    'Loop through all hyperlinks.
    For i = 1 To doc.Hyperlinks.Count

        x = Len(CStr(doc.Hyperlinks(i).Address))

        If x > 1 Then ' to make sure that the link is not empty

            strHyperlinkURL = CStr(doc.Hyperlinks(i).Address)

            doc.Hyperlinks(i).Range.Paragraphs(1).Range.Select

            strHyperlinkParaText = Selection.Text


        End If 'If x > 1 

    Next 'For i = 1 To doc.Hyperlinks.Count

End Sub  'subFindNdRemovHyprlnksAndInsert2NewLinks

macropod · #2 12-30-2016, 04:56 PM

Try the following macro.

Notes:
1. None of the hyperlinks in your document are in paragraphs using the Heading 1 Style - they use a variety of other styles.
2. Some paragraphs have multiple hyperlinks, so only the first one is processed.
3. As coded, the macro adds the new hyperlink to the first word in the paragraph (i.e. the word after the paragraph's #).

Code:

Sub Demo()
Application.ScreenUpdating = False
Dim RngDoc As Range, RngLnk As Range, HLnk As Hyperlink, StrAddr
With ActiveDocument
  Set RngDoc = .Range: Set RngLnk = .Range(0, 0)
  If .TablesOfContents.Count > 0 Then
    RngDoc.Start = .TablesOfContents(.TablesOfContents.Count).Range.End
  End If
End With
For Each HLnk In RngDoc.Hyperlinks
  If HLnk.Range.Paragraphs(1).Range <> RngLnk Then
    Set RngLnk = HLnk.Range.Paragraphs(1).Range
    With RngLnk
      StrAddr = .Hyperlinks(1).Address
      HLnk.Range.Fields(1).Unlink
      .Hyperlinks.Add Anchor:=.Words.First, Address:=StrAddr, TextToDisplay:=.Words.First.Text
    End With
  End If
Next
Application.ScreenUpdating = True
End Sub

marceepoo · #3 12-30-2016, 09:04 PM

You are such a nice guy!!!!
Thank you.
Marc

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Find last word in paragraph and delete it	Dave T	Word VBA	3	05-21-2015 12:40 AM
How to find and delete duplicate words in doc	cinvest	Word	1	09-29-2014 08:34 PM
Macro to Delete Duplicate Rows and Retain Unique Value	expert4knowledge	Excel Programming	1	02-17-2014 08:02 PM
Find all email addresses in word document and delete	Chayes	Word VBA	14	10-22-2013 06:30 AM
Insert Multiple hyperlinks to word repeated in doc - easily	synses	Word	8	02-24-2012 05:17 AM