Sub ListHyperlinks()
Application.ScreenUpdating = False
Dim HLnk As Hyperlink, StrTxt As String, Dest
Dim wdDocIn As Document, wdDocOut As Document
Dest = MsgBox(Prompt:="Output to New Document? (Y/N)", _
  Buttons:=vbYesNoCancel, Title:="Destination Selection")
If Dest = vbCancel Then Exit Sub
Set wdDocIn = ActiveDocument
If Dest = vbYes Then Set wdDocOut = Documents.Add
If Dest = vbNo Then Set wdDocOut = wdDocIn
StrTxt = vbCr & "Hyperlink Display Text" & vbTab & "Hyperlink Address"
With wdDocIn
  For Each HLnk In .Hyperlinks
    StrTxt = StrTxt & vbCr & HLnk.TextToDisplay & vbTab & HLnk.Address
  Next HLnk
End With
wdDocOut.Range.InsertAfter StrTxt
Set wdDocIn = Nothing: Set wdDocOut = Nothing
Application.ScreenUpdating = True
End Sub