Extract Hyperlinks from Multiple word documents

[Bullracer2]

Hi,

I have a number of word documents which reside in a folder which i want to search through and extract all the hyperlinks into either word or excel (not fussed which) I previously posted a similar query a few months ago trying to get the info into excel without luck and my latest effort involves an output to word, but I'm missing some logic in here as well



Sub ExtHyper()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document 'active document
Dim wdDocHp As Document
Dim Hyper As Hyperlink
Dim rngstory As StoryRanges
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = ActiveDocument
Set wdDocHp = Documents.Add
For Each Hyper In wdDoc.Hyperlinks
Hyper.Range.Copy
wdDocHp.Activate
Selection.Paste
Selection.TypeParagraph
Next
Wend
wdDoc.SaveAs "C:\hyperlinks.docx"
Set wdDoc = Nothing
Set wdDocHp = Nothing
Application.ScreenUpdating = True
End Sub

Any help would be appreciated.

Thanks,

[fumei]

What seems to be the problem? You do seem to be created a separate document for each document though. Is this what you want?

[Bullracer2]

Thanks for the reply. Word just goes into a loop constantly creating new blank word documents. I have to end task word to stop the macro. and no hyperlinks.docx file gets created in the c:\

The test files im using just contain two word documents each with two hyperlinks and some basic text.

And yes i would like it all summarised into just one document. (Don't need the path from which the hyperlink originated as i'm really just after the different hyperlinks these word documents reference - though it would be nice if it was easy)

[macropod]

Try:

Sub ExtHyper()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
Dim wdDocHp As Document, wdDoc As Document, HLnk As Hyperlink
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set wdDocHp = Documents.Add
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
For Each HLnk In wdDoc.Hyperlinks
HLnk.Range.Copy
With wdDocHp.Range.Characters.Last
.Paste
.InsertAfter vbCr
End With
Next
Wend
wdDocHp.SaveAs2 FileName:="C:\hyperlinks.docx", Fileformat:=wdFormatXMLDocument, AddToRecentFiles:=False
Set wdDoc = Nothing: Set wdDocHp = Nothing
Application.ScreenUpdating = True
End SubSub
PS: Your reference to "the path from which the hyperlink originated" is ambiguous.

[fumei]

Yeah, it does help to actually open something....