Форум по VBA и MS Office

Sub макрос()
   
    Dim hyps_main As Collection, hyps_footenotes As Collection, hyps_endnotes As Collection
    Dim doc_report As Document
   
   
    '1. Поиск гиперссылок.
    '1) Основной текст.
    Set hyps_main = New Collection
    MainStory ActiveDocument.StoryRanges(wdMainTextStory), hyps_main
    '2) Страничные сноски.
    ' Коллекции создаются в любом случае, чтобы затем работать со свойстом "Count".
    Set hyps_footenotes = New Collection
    If ActiveDocument.Footnotes.Count <> 0 Then
        MainStory ActiveDocument.StoryRanges(wdFootnotesStory), hyps_footenotes
    End If
    '3) Концевые сноски.
    Set hyps_endnotes = New Collection
    If ActiveDocument.Endnotes.Count <> 0 Then
        MainStory ActiveDocument.StoryRanges(wdEndnotesStory), hyps_endnotes
    End If
   
    ' Если в файле нет гиперссылок (ни в основном тексте, ни в сносках).
    If hyps_main.Count + hyps_footenotes.Count + hyps_endnotes.Count = 0 Then
        MsgBox "Гиперссылок нет.", vbInformation
        Exit Sub
    End If
   
    '2. Запись номеров страниц в новый ворд-файл.
    ' Создание ворда файла и присвоение ему имени "doc_res". Далее в коде
        ' можно обращаться к этому файлу по этому имени.
    Set doc_report = Documents.Add
    ' Копирование данных из коллекций в новый файл.
    If hyps_main.Count <> 0 Then WriteDocreport "Гиперссылки в основном файле:", hyps_main, doc_report
    If hyps_footenotes.Count <> 0 Then WriteDocreport "Гиперссылки в страничных сносках:", hyps_footenotes, doc_report
    If hyps_endnotes.Count <> 0 Then WriteDocreport "Гиперссылки в концевых сносках:", hyps_endnotes, doc_report
   
    ' 3. Сообщение.
    MsgBox "В файле есть гиперссылки. Номера строк записаны в новый ворд-файл, который " & _
        "отображён на мониторе.", vbExclamation
   
End Sub

Private Sub MainStory(StoryRange As Range, hyps As Collection)
   
    ' Эта процедура запишет в коллекцию номера страниц, на которых находятся гиперссылки.
        ' Коллекция в данном случае будет использоваться не только для сбора номеров страниц,
        ' но и для сбора уникальных номеров страниц, чтобы юзеру было удобнее.
       
    ' У переменной "PageNumber" используется тип данных String, хотя
        ' в переменную будет записано число, для коллекции, для записи в Key,
        ' т.к. в Key можно записать только тип данных String.
    Dim hyp As Hyperlink, PageNumber As String
   
   
    '1. Включение перехватчика ошибок, чтобы макрос продолжил работу при возникновении ошибки.
        ' Ошибка возникнет, если макрос будет пытаться записать в коллекцию уже имеющийся
        ' в коллекции номер страницы.
    On Error Resume Next
   
    ' Цикл по всем гиперссылкам в основном тексте.
    For Each hyp In StoryRange.Hyperlinks
       
        '2. Запись в переменную "PageNumber" номера страницы, где находится гиперссылка.
            ' Переменная используется, чтобы упростить код, т.к. в коллекцию номер
            ' страницы надо будет записать два раза и получится длинный код.
        PageNumber = hyp.Range.Information(wdActiveEndPageNumber)
       
        '3. Запись в коллекцию номера страницы, где находится гиперссылка.
            ' В Item номер страницы записывается, чтобы отобразить в сообщении,
            ' в Key, чтобы собирать уникальные номера страниц.
        hyps.Add Item:=PageNumber, Key:=PageNumber
       
    Next hyp
   
    '4. Отключение перехватчика ошибок, чтобы увидеть непредвиденные ошибки,
        ' чтобы потом их исправить.
    On Error GoTo 0

End Sub

Private Sub WriteDocreport(header As String, hyps As Collection, doc_report As Document)

    ' Копирование данных из коллекций в новый файл.

    Dim i As Long
   
    doc_report.Range.InsertAfter Text:=header & Chr(13)
    For i = 1 To hyps.Count
        doc_report.Range.InsertAfter hyps(i) & Chr(13)
    Next i
   
    ' Вставка ещё одного пустого абзаца, чтобы между разделами был пустой абзац.
    doc_report.Range.InsertParagraphAfter
   
End Sub