Extract Links From Word

Sub ExtractURL()
'
' ExtractURL Macro
'
'

Dim oHpl As Hyperlink
Dim dAD As Document 'active document
Dim dDc2 As Document 'new document
Dim rngStory As StoryRanges
Dim rng As Range
Dim intFootnotes As Integer

    Set dAD = ActiveDocument
    Set dDc2 = Documents.Add
    Selection.TypeText "Hyperlinks found in main document story: " & dAD.StoryRanges(wdMainTextStory).Hyperlinks.Count
    Selection.TypeParagraph
    Set rng = dDc2.Range
    rng.Collapse wdCollapseEnd
    For Each oHpl In dAD.StoryRanges(wdMainTextStory).Hyperlinks
        oHpl.Range.Copy
        dDc2.Activate
        Selection.Paste
        Selection.TypeParagraph
    Next
    On Error Resume Next
    intFootnotes = dAD.StoryRanges(wdFootnotesStory).Hyperlinks.Count
    On Error GoTo 0
    If intFootnotes = 0 Then
        Selection.TypeText "Hyperlinks found in Footnotes: 0"
    Else
        Selection.TypeText "Hyperlinks found in Footnotes: " & dAD.StoryRanges(wdFootnotesStory).Hyperlinks.Count
        Selection.TypeParagraph
        For Each oHpl In dAD.StoryRanges(wdFootnotesStory).Hyperlinks
            oHpl.Range.Copy
            dDc2.Activate
            Selection.Paste
            Selection.TypeParagraph
        Next
    End If
    dDc2.SaveAs "h:hyperlinks.docx"
    Set dAD = Nothing
    Set dDc2 = Nothing
End Sub