Use Word VBA to find, delete and insert duplicate hyperlinks
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.
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
Last edited by macropod; 12-29-2016 at 10:09 PM. Reason: Attachment localised, code tags added
Try the following macro.
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 #).
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
[MS MVP - Word]
|hyperlinks, search and replace, vba in microsoft word|
|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|