I need VBA code to extract hyperlinks and associated text from a Word document to a .csv file

One of our users is reporting that hyperlinks in a Word document they use keep changing. The hyperlinks are paths to folders on our file storage system. I wanted to extract all the hyperlinked paths so I can study this behavior. I found this page

https://www.extendoffice.com/documents/word/1411-word-select-copy-all-hyperlinks.html#a2

and used the VBA code to extract the underlying paths to a new document, but I need more than what this provides.

1. I would like VBA code to export the underlying paths to a .csv file in column A and I want the text which is associated with the respective hyperlink in column B.
2. The author of the code says it does not extract the hyperlinks in the same order as they occurred in the original document but I do want them in the original order.

Thanks,
Don
donanderAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Neil FlemingConsultant and developerCommented:
Try this. You need to change the path in line 9 to your desired output CSV file. Apart from that, this will output all hyperlinks in the correct order.

Note that if there are hyperlinks in textboxes etc, we may have to add to the code to check those as well.

Sub getHyperlinks()
    Dim hLink As Hyperlink, hThis As Hyperlink
    Dim docCurrent As Document 'current document
    Dim sPath As String, sFile As String
    Dim iFile As Long, iMin As Long, iMax As Long
    
    On Error GoTo errortrap
    'change this to your desired filename
    sPath = "c:\neil work\test.csv"
    iFile = FreeFile
    sFile = Dir(sPath)
    'delete old file
    If sPath <> "" Then Kill sPath
    Open sPath For Output As #iFile
    
    Set docCurrent = ActiveDocument
    iMin = 0
    Do
    Set hThis = Nothing
    iMax = docCurrent.Range.End
    'find hyperlinks in order
    For Each hLink In docCurrent.Hyperlinks
'look for the hyperlink which occurs earliest in the document after the previous output:
    If (hLink.Range.Start < iMax) And (hLink.Range.Start > iMin) Then
    Set hThis = hLink
    iMax = hThis.Range.Start
    End If
    Next
    
    If Not (hThis Is Nothing) Then
    Write #iFile, hThis.Address, hThis.Range.Text
    'redefine imin for the next loop
    iMin = iMax
    End If
    
    Loop Until hThis Is Nothing
    Close #iFile
    Exit Sub
errortrap:
MsgBox ("Can't delete old file. It may be open")
    
    
    
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Neil FlemingConsultant and developerCommented:
Also, if it's helpful, you could also output the position of the hyperlink in the document to Column C using:
Write #iFile, hThis.Address, hThis.Range.Text, hThis.Range.Start

Open in new window

0
NorieVBA ExpertCommented:
Don

How have the hyperlinks in the Word document(s) been created?
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

donanderAuthor Commented:
The user selects the text they want to hyperlink then right-clicks and chooses "Hyperlink" from the context menu then navigates in the wizard to the path where the document, usually another Word document or an Excel file lives. For example they end up with a UNC path something like this:

\\contoso.com\engineering\templates\how to make a widget.docx

Don
0
Zeth LarssonCommented:
Is this what you need?
It shall be executed in the MS Word document that has the links you want to export.
Then open the CSV file in MS Excel, and hyperlink will be in column A, and the assocciated text in column B.
You will find the CSV file in the same folder as the MS Word document.
Need more advice? Post a comment about it.
Just a small modification of some code found in you link.

Sub HyperlinksExtract()
    Dim oLink As Hyperlink
    Dim docCurrent As Document 'current document
    Dim docNew As Document 'new document
    Dim rngStory As StoryRanges
    Dim strTargetCSV As String
    Set docCurrent = ActiveDocument
    Set docNew = Documents.Add
    strTargetCSV = docCurrent.Path & "\link.CSV"
   
    Open strTargetCSV For Output As #1
   
    For Each oLink In docCurrent.Hyperlinks
        oLink.Range.Copy
        docNew.Activate
        Selection.Paste
        'Debug.Print oLink.Address & "  " & oLink.TextToDisplay
        Print #1, oLink.Address & ";" & oLink.TextToDisplay             ' Change order here to suit your needs.
        Selection.TypeParagraph
    Next
   
    Close #1
    Set docNew = Nothing
    Set docCurrent = Nothing
End Sub
0
donanderAuthor Commented:
Zeth,

I think there is a small bug. It works as expected but the path and the text are both in column A with a semicolon ( ; ) between the path and the text from the Word document. I could probably parse this in Excel but can you see how to fix this in the code?

Thanks
Don
0
NorieVBA ExpertCommented:
Don

I think Zeth's code only needs some minor adjustment, try this.
Sub HyperlinksExtract()
Dim docCurrent As Document    'current document
Dim oLink As Hyperlink
Dim strTargetCSV As String

    Set docCurrent = ActiveDocument
    strTargetCSV = docCurrent.Path & "\link.CSV"

    Open strTargetCSV For Output As #1

    For Each oLink In docCurrent.Hyperlinks
        Print #1, oLink.Address & "," & oLink.TextToDisplay
    Next

    Close #1
    
    Set docCurrent = Nothing
    
End Sub

Open in new window

0
donanderAuthor Commented:
Hi Norie,
 I have left work for the day but I will try this tomorrow and let you know.
Thanks,
Don
0
Neil FlemingConsultant and developerCommented:
hmm.. how is this any different from the solution I posted before any of this...?

The only difference I can see is that my code guarantees export of the links in the correct order, whereas later efforts do not.
0
Zeth LarssonCommented:
Comma or semicolon separation, I belive is a matter of country version of MS Excel. "," did not work for me. It become one single string of both data.
I'l remeber to point on that next time.
Neil, if you code work as donander want to, I'v not tryed it, then the solution is yours, of course.
0
donanderAuthor Commented:
I forgot to post the results of Neil's code. When I run it I get the error

"Can't delete old file. It may be open"

Neil, can you see what might be wrong?

Thanks,
Don
0
Neil FlemingConsultant and developerCommented:
Did you change the file path and name to a path that exists on your machine?

I wrote that error message for any error that might occur, somewhat casually, since the most likely error is that you create the csv file, open it, and then try to run the code again.

If you comment out the "onError" line, it should tell you what the actual error is.
0
donanderAuthor Commented:
Yes, I changed the path on the line below as shown. The Word document is in this same folder.

sPath = "d:\snoopdon\test.csv"

When I remark the "OnError" I get:

Run-time error '53':
File not found

If I click Debug it highlights "Kill sPath" in the line below in yellow.

If sPath <> "" Then Kill sPath

Don
0
Neil FlemingConsultant and developerCommented:
ah, sorry. Stupid mistake in my code. It was trying to delete sPath instead of sFile. Try this instead:
Sub getHyperlinks()
    Dim hLink As Hyperlink, hThis As Hyperlink
    Dim docCurrent As Document 'current document
    Dim sPath As String, sFile As String
    Dim iFile As Long, iMin As Long, iMax As Long
    
    On Error GoTo errortrap
    'change this to your desired filename
    sPath = "c:\neil work\test9.csv"
    iFile = FreeFile
    sFile = Dir(sPath)
    'delete old file
    If sFile <> "" Then Kill sFile
    Open sFile For Output As #iFile
    
    Set docCurrent = ActiveDocument
    iMin = 0
    Do
    Set hThis = Nothing
    iMax = docCurrent.Range.End
    'find hyperlinks in order
    For Each hLink In docCurrent.Hyperlinks
    If (hLink.Range.Start < iMax) And (hLink.Range.Start > iMin) Then
    Set hThis = hLink
    iMax = hThis.Range.Start
    End If
    Next
    
    If Not (hThis Is Nothing) Then
    Write #iFile, hThis.Address, hThis.Range.Text
    'redefine imin
    iMin = iMax
    End If
    
    Loop Until hThis Is Nothing
    Close #iFile
    Exit Sub
errortrap:
MsgBox ("Can't delete old file. It may be open")
    
    
    
End Sub

Open in new window

0
donanderAuthor Commented:
Ok, I am still getting "Can't delete old file. It may be open." when I run the macro.

If I remark "OnError..." I see this:

Run time error '75':
Path/File access error

If I click the Debug button it highlights the line below in yellow. At least it is a different line :-)

Open sFile For Output As #iFile

I did change

sPath = "c:\neil work\test9.csv"

to

sPath = "d:\snoopdon\test9.csv"

The document is in d:\snoopdon.

Thanks,
Don
0
Zeth LarssonCommented:
I belive it is a small misstake on Neils code.
Do this modification är try again.

Comment out the first line, and add the second after that.
    ' Open sFile For Output As #iFile
    Open "c:\neil work\test9.csv" For Output As #iFile

Or with other words, replace sFile with "c:\neil work\test9.csv" in the open statement.

The reason is that the line
sFile = Dir(sPath)
return null to sFile, as there is no file in sPath yet.

I had also to change the the line:
Write #iFile, hThis.Address, hThis.Range.Text
to:
Print #iFile, hThis.Address & "," & hThis.Range.Text

If you left the CSV file open in XL, and try to run the script a second time, you get an error, because the file is locked to delete by XL. Close file and run then.
0
Neil FlemingConsultant and developerCommented:
Thank you, Zeth.. and my apologies for writing the code in such a hurry not to have checked the file opening stuff properly.

In my haste, I changed the first version too quickly and broke it again. This will also work fine:
'change this to your desired filename
    sPath = "c:\neil work\test9.csv"
    iFile = FreeFile
    sFile = Dir(sPath)
    'delete old file if it exists
    If sFile <> "" Then Kill sFile
    Open sPath For Output As #iFile

Open in new window

0
Zeth LarssonCommented:
It's 1-1 between us! Norie helped me :-)
If it works now, it schould yet be your nice code that get the solution!
0
Neil FlemingConsultant and developerCommented:
lol.. too embarrassed to accept them :)
0
donanderAuthor Commented:
After making the edit in the code that Zeth suggested, the code now works exactly as I had requested.

Thanks much to Zeth and Neil for providing a great solution and for collaborating together to achieve it.

This is what sets Experts Exchange apart from all the forums on the web where there is virtually no collaboration.

Don
1
Neil FlemingConsultant and developerCommented:
Pleasure. Apologies again for the stoopid mistakes..
0
Zeth LarssonCommented:
Stupid mistake!? Yet we are making all human mistakes - thank goodness:-)
1
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Office

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.