【Word VBA/マクロ】ハイパーリンクの一覧作成

サンプルコードでできること

ハイパーリンクのリストを別文書に作成します。

リストの内容
1列目　ハイパーリンクの設定されているページ
2列目　表示文字列
3列目　リンク先

プログラムの説明

    For Each hpLink In ActiveDocument.Hyperlinks
        With hpLink
            If .Address <> "" Then
                hprList = hprList & .Range.Information(wdActiveEndPageNumber) _
                    & vbTab & .TextToDisplay & vbTab & .Address & vbCrLf
            ElseIf .SubAddress <> "" Then
                hprList = hprList & .Range.Information(wdActiveEndPageNumber) _
                    & vbTab & .TextToDisplay & vbTab & .SubAddress & vbCrLf
            End If
        End With
    Next

For Eachの構文で、ハイパーリンクが見つかるたび、ハイパーリンクのページ、文字列、リンク先を変数に格納します。
外部へのリンク先はAddress、文書内へのリンクはSubAddress で取得できます。
「 If .Address <> "" Then」と「ElseIf .SubAddress <> ""」で、リンク先を判定。
いずれかのリンク先を変数hprList へ格納しています。

            For r = 2 To .Rows.Count
                With .Cell(r, 3).Range
                    If Left(.Text, 1) = "_" Then
                        .Font.ColorIndex = wdBlue
                    End If
                End With
            Next

文書内へのリンクは、分かりやすいように文字を青色にしています。
SubAddress で文書内へのリンクを取得すると、リンク先のテキストの前に「_」が付くようです。
セルの最初に「_」がある場合は、文書内へのリンクとみなして、フォントの色を青にしています。

Sub GetHyperlinkList()
'ハイパーリンクのリストを作成します。
    Dim hpLink As Hyperlink, hprList As String
    Dim subHpLink As String, bl As Boolean
    Dim dcNew As Document
    If ActiveDocument.Hyperlinks.Count = 0 Then
        MsgBox "ハイパーリンクはありません"
        Exit Sub
    End If

    For Each hpLink In ActiveDocument.Hyperlinks
        With hpLink
            If .Address <> "" Then
                hprList = hprList & .Range.Information(wdActiveEndPageNumber) _
                    & vbTab & .TextToDisplay & vbTab & .Address & vbCrLf
            ElseIf .SubAddress <> "" Then
                hprList = hprList & .Range.Information(wdActiveEndPageNumber) _
                    & vbTab & .TextToDisplay & vbTab & .SubAddress & vbCrLf
                    bl = True
            End If
        End With
    Next
    
    Set dcNew = Documents.Add
    With dcNew.PageSetup
        .TopMargin = MillimetersToPoints(20)
        .BottomMargin = MillimetersToPoints(20)
        .LeftMargin = MillimetersToPoints(20)
        .RightMargin = MillimetersToPoints(20)
    End With
    dcNew.Range(0, 0).InsertBefore hprList
    
    With Selection
        .WholeStory
        .ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=3, _
            NumRows:=3, AutoFitBehavior:=wdAutoFitFixed
        .InsertRowsAbove 1
        .TypeText Text:="ページ"
        .MoveRight Unit:=wdCell
        .TypeText Text:="表示文字列"
        .MoveRight Unit:=wdCell
        .TypeText Text:="リンク先"
        With .Tables(1)
            .Style = "表 (格子)"
            .ApplyStyleHeadingRows = True
            .PreferredWidthType = wdPreferredWidthPercent
            .PreferredWidth = 100
            .Columns(1).PreferredWidth = 5
            .Columns(2).PreferredWidth = 35
            .Columns(3).PreferredWidth = 60
            Dim r As Long, c As Long
            For r = 2 To .Rows.Count
                With .Cell(r, 3).Range
                    If Left(.Text, 1) = "_" Then
                        .Font.ColorIndex = wdBlue
                    End If
                End With
            Next
        End With
        If bl = True Then
            .EndKey wdStory
            .InsertAfter "※青のテキストは文書内へのリンクです。"
            .Range.Bold = True
        End If
    End With
    ActiveDocument.Range(0, 0).Select
End Sub