Dim fso As FileSystemObject ' Declare a FileSystemObject.
Dim stream As TextStream ' Declare a TextStream.
Sub ListHyperlinks()
    
    Dim i As Integer
    Dim Rng As Range
    Dim strMid As String


    Set fso = New FileSystemObject ' Create a FileSystemObject.
    Set stream = fso.CreateTextFile("C:\Test1.txt", True)  

    Application.ScreenUpdating = False
    
    With ActiveDocument
        For i = .Hyperlinks.Count To 1 Step -1
            With .Hyperlinks(i)
                Set Rng = .Range
                strMid = Mid(Rng, 36, 75)
                stream.WriteLine (strMid)
            End With
        Next
    End With
    
    ' Close the file.
    stream.Close

    Application.ScreenUpdating = True
    
End Sub