Word VBA Макросы. Преобразовать концевые сноски Word в текст.

[BoomZoom]

Есть такая задача: документ из разделов, в конце каждого раздела есть концевые сноски.

Нужно все сноски преобразовать в простой текст (а ссылки на сноски - просто в текст в верхнем индексе),
сноски должны располагаться там же - в конце раздела. Мечтой, конечно, было-бы еще и размещение линии сноски, заменив ее просто обычной короткой линией.
То есть получится почти такая же структура текста, только без функционала сносок - только обычный текст.

Нашел что-то близкое, но не то:

Макрос:

Sub fnToText()
'преобразование сносок в обычный текст
Dim actdoc As Document
Dim fn As Word.Footnote
Dim rngFN As Word.Range
Dim i As Long
Set actdoc = ActiveDocument
'работаем со сносками в обратном порядке (от последней до первой)
For i = actdoc.Footnotes.Count To 1 Step -1
Set fn = actdoc.Footnotes(i)  'запоминаем сноску
Set rngFN = fn.Reference  'определяем ссылку на сноску (знак сноски)
rngFN.Collapse wdCollapseEnd  'перемещаемся в конец слова со знаком сноски
'вставляем текст сноски после знака сноски с сохранением форматирования
rngFN.FormattedText = fn.Range.FormattedText
rngFN.InsertBefore Chr(32) & Chr(151) & Chr(32)  'вставляем длинное тире
fn.Delete 'удаляем сноски
Next i
End Sub

[свернуть]

[Администратор]

Выложите файл-пример. Оставьте в этом файле только два раздела.
Чтобы быть уверенным, что мы думаем об одном и том же.

[BoomZoom]

Пример прикладываю (материал авторский - чуть изменил, но суть - та же).

[вложение удалено администратором]

[Администратор]

Задача сложная - нельзя узнать отображаемый номер сноски с помощью макроса - нужно производить вычисления.
Могу только попробовать сделать для конкретной ситуации, например, как в вашем примере: в каждом разделе своя нумерация концевых сносок.
Если в каком-то ворд-файле будет сквозная нумерация, то макрос не будет правильно работать.

[BoomZoom]

Ваш вариант решения меня полностью устроит! Сквозной у меня не будет точно!

[Администратор]

Посмотрите, всё ли нормально.

Макрос:

Sub Main()

    ' Макрос расчитан на работу с концевыми сносками, которые имеют свою нумерацию в каждом разделе (а не общую).
   
    Dim docAct As Document, sec As Section, objEndNote As Endnote, parSec As Paragraph, parNote As Paragraph
    Dim rng As Range, i_sec As Long, i_note As Long, i As Long
   
   
    '1. Vba-именование активного ворд-файла.
    Set docAct = ActiveDocument
   
    '2. Замена у концевых сносок номеров-полей на обычные числа, чтобы потом просто копировать сноски в текст.
    For Each sec In docAct.Sections
        For i = 1 To sec.Range.Endnotes.Count Step 1
            ' Искать нужно с использованием параграфа, иначе номер не входит в диапазон.
            With sec.Range.Endnotes(i).Range.Paragraphs(1).Range.Find
                .Text = "^0002"
                .Replacement.Text = i
                .Execute Replace:=wdReplaceOne
            End With
        Next i
    Next sec
   
    '3. Копирование сносок внутрь разделов (во все, кроме последнего).
        ' Для последнего нужно по-другому делать, проблема в том, что если вставлять
        ' скопированный абзац в первом разделе (или другом), то пустой абзац исчезает,
        ' а в последнем разделе остаётся.
    For i_sec = 1 To docAct.Sections.Count - 1 Step 1
   
        ' Vba-именование раздела.
        Set sec = docAct.Sections(i_sec)
   
        ' Если в разделе нет концевых сносок.
        If sec.Range.Endnotes.Count = 0 Then
            GoTo metka1
        End If
       
        ' Вставка пустых абзацев между текстом и сносками (для удобства юзера).
        sec.Range.Paragraphs.Last.Previous.Range.InsertAfter Text:=String(4, Chr(13))
       
        ' Вставка псевдоразделителя сноски.
        With sec.Range.Paragraphs.Last.Previous(2).Range.Borders(wdBorderBottom)
            .LineStyle = wdLineStyleSingle
            .LineWidth = wdLineWidth025pt
            .Color = wdColorAutomatic
        End With
        With sec.Range.Paragraphs.Last.Previous(2).Range.ParagraphFormat
            .RightIndent = CentimetersToPoints(12)
            .SpaceBeforeAuto = False
            .SpaceAfterAuto = False
            .SpaceAfter = 6
        End With

        ' Копирование абзацев сносок в конец раздела.
        ' Копируются именно абзацы, чтобы сохранялось полностью всё форматирование.
        ' Используется цикл с "i", а не c "each", т.к. почему-то после вставки пустых абзацев
            ' цикл снова начинается.
        For i_note = 1 To sec.Range.Endnotes.Count Step 1
            ' Vba-именование сноски.
            Set objEndNote = sec.Range.Endnotes(i_note)
            ' Предполагается, что в сноске может быть несколько абзацев.
            For Each parNote In objEndNote.Range.Paragraphs
                ' Куда вставлять.
                sec.Range.Paragraphs.Last.Previous.Range.InsertParagraphAfter
                parNote.Range.Copy
                sec.Range.Paragraphs.Last.Previous(2).Range.Paste
            Next parNote

        Next i_note
       
metka1:
    Next i_sec
   
    '4. Копирование сносок внутрь последнего раздела.
   
    ' Vba-именование раздела.
    Set sec = docAct.Sections.Last
    ' Если нет сносок.
    If sec.Range.Endnotes.Count = 0 Then
        GoTo metka2
    End If
    ' Вставка пустых абзацев между текстом и сносками (для удобства юзера).
    sec.Range.InsertAfter Text:=String(3, Chr(13))
    ' Вставка псевдоразделителя сноски.
    With sec.Range.Paragraphs.Last.Previous.Range.Borders(wdBorderBottom)
        .LineStyle = wdLineStyleSingle
        .LineWidth = wdLineWidth025pt
        .Color = wdColorAutomatic
    End With
    With sec.Range.Paragraphs.Last.Previous.Range.ParagraphFormat
        .RightIndent = CentimetersToPoints(12)
        .SpaceBeforeAuto = False
        .SpaceAfterAuto = False
        .SpaceAfter = 6
    End With
    ' Vba-именование абзаца, в который надо вставлять.
    Set parSec = sec.Range.Paragraphs.Last
    ' Копирование абзацев сносок в конец раздела.
    For i = 1 To sec.Range.Endnotes.Count Step 1
        ' Vba-именование сноски.
        Set objEndNote = sec.Range.Endnotes(i)
        For Each parNote In objEndNote.Range.Paragraphs
            parNote.Range.Copy
            parSec.Range.Paste
        Next parNote
    Next i
   
metka2:
   
    '5. Замена номеров-полей сносок в самом тексте.
    For Each sec In docAct.Sections
        ' Двигаться нужно от последней, т.к. происходит удаление сносок.
        For i = sec.Range.Endnotes.Count To 1 Step -1
            ' Запоминание места, чтобы потом оформить, т.к. после замены сноска будет удалена.
            Set rng = sec.Range.Endnotes(i).Reference
            rng.Text = i
            rng.Style = "Знак сноски"
        Next i
    Next sec
   
    '6. Сообщение.
    MsgBox "Макрос завершил работу.", vbInformation

End Sub

[свернуть]

[BoomZoom]

Огромное преогромное спасибо! Не думал, что это целая программа. Все работает!!! Проверял на огромном тексте (360 листов) и тремя десятками разделов. Это супер!

Примечания такие: если курсор у меня стоит в середине текста при запуске макроса - макрос приходится завершать вручную, очень долго работает и никак не завершается, если на первом листе - все отрабатывает как надо.

Есть еще вопрос: после текста перед псевдолинией ставятся 3 абзаца, думаю, не просто так, но можно ли к как-то их потом убрать, с учетом того, что у меня есть в тексте места, где стоят несколько абзацев (3-4 абзаца) и они нужны.

[Администратор]

Новая версия. В этой версии в начале работы макроса курсор переходит в начало файла. И макрос больше не вставляет пустые абзацы между текстом и псевдосносками.

Макрос

Sub Main()

    ' Макрос расчитан на работу с концевыми сносками, которые имеют свою нумерацию в каждом разделе (а не общую).
   
    Dim docAct As Document, sec As Section, objEndNote As Endnote, parNote As Paragraph
    Dim rng As Range, i_sec As Long, i_note As Long, i As Long
   
   
    '1. Vba-именование активного ворд-файла.
    Set docAct = ActiveDocument
   
    '2. Переход в начала файла, иначе (по неизвестным причинам) макрос не завершается (нужно прерывать).
    Selection.HomeKey Unit:=wdStory
   
    '3. Замена у концевых сносок номеров-полей на обычные числа, чтобы потом просто копировать сноски в текст.
    For Each sec In docAct.Sections
        For i = 1 To sec.Range.Endnotes.Count Step 1
            ' Искать нужно с использованием параграфа, иначе номер не входит в диапазон.
            With sec.Range.Endnotes(i).Range.Paragraphs(1).Range.Find
                .Text = "^0002"
                .Replacement.Text = i
                .Execute Replace:=wdReplaceOne
            End With
        Next i
    Next sec
   
    '4. Копирование сносок внутрь разделов (во все, кроме последнего).
        ' Для последнего нужно по-другому делать, проблема в том, что если вставлять
        ' скопированный абзац в первом разделе (или другом), то пустой абзац исчезает,
        ' а в последнем разделе остаётся.
    For i_sec = 1 To docAct.Sections.Count - 1 Step 1
   
        ' Vba-именование раздела.
        Set sec = docAct.Sections(i_sec)
   
        ' Если в разделе нет концевых сносок.
        If sec.Range.Endnotes.Count = 0 Then
            GoTo metka1
        End If
       
        ' Вставка пустого абзаца для псевдоразделителя и сносок.
        ' Если предпоследний абзац не пустой.
        If sec.Range.Paragraphs.Last.Previous.Range.Characters.Count <> 1 Then
            sec.Range.Paragraphs.Last.Previous.Range.InsertParagraphAfter
        End If
       
        ' Вставка псевдоразделителя сноски.
        sec.Range.Paragraphs.Last.Previous.Range.InsertParagraphAfter
        Call pInsSeparator(sec.Range.Paragraphs.Last.Previous(2).Range)

        ' Копирование абзацев сносок в конец раздела.
        ' Копируются именно абзацы, чтобы сохранялось полностью всё форматирование.
        ' Используется цикл с "i", а не c "each", т.к. почему-то после вставки пустых абзацев
            ' цикл снова начинается.
        For i_note = 1 To sec.Range.Endnotes.Count Step 1
            ' Vba-именование сноски.
            Set objEndNote = sec.Range.Endnotes(i_note)
            ' Предполагается, что в сноске может быть несколько абзацев.
            For Each parNote In objEndNote.Range.Paragraphs
                ' Куда вставлять.
                sec.Range.Paragraphs.Last.Previous.Range.InsertParagraphAfter
                parNote.Range.Copy
                sec.Range.Paragraphs.Last.Previous(2).Range.Paste
            Next parNote
        Next i_note
        ' Удаление в последнем абзаце с текстом знака абзаца, чтобы разрыв стал в одной строке с этим абзацем,
            ' чтобы не было после раздела лишнего пустого абзаца.
        sec.Range.Paragraphs.Last.Previous(2).Range.Characters.Last.Delete
       
        ' Может быть это улучшит.
        DoEvents
metka1:
    Next i_sec
   
    '5. Копирование сносок внутрь последнего раздела.
   
    ' Vba-именование раздела.
    Set sec = docAct.Sections.Last
    ' Если нет сносок.
    If sec.Range.Endnotes.Count = 0 Then
        GoTo metka2
    End If
    ' Вставка пустого абзаца для псевдоразделителя и сносок.
    ' Если последний абзац не пустой.
    If sec.Range.Paragraphs.Last.Range.Characters.Count <> 0 Then
        sec.Range.InsertParagraphAfter
    End If
    ' Вставка псевдоразделителя сноски.
    sec.Range.InsertParagraphAfter
    Call pInsSeparator(sec.Range.Paragraphs.Last.Previous.Range)
    ' Копирование абзацев сносок в конец раздела.
    For i = 1 To sec.Range.Endnotes.Count Step 1
        ' Vba-именование сноски.
        Set objEndNote = sec.Range.Endnotes(i)
        For Each parNote In objEndNote.Range.Paragraphs
            parNote.Range.Copy
            sec.Range.Paragraphs.Last.Range.Paste
        Next parNote
    Next i
   
metka2:
   
    '6. Замена номеров-полей сносок в самом тексте.
    For Each sec In docAct.Sections
        ' Двигаться нужно от последней, т.к. происходит удаление сносок.
        For i = sec.Range.Endnotes.Count To 1 Step -1
            ' Запоминание места, чтобы потом оформить, т.к. после замены сноска будет удалена.
            Set rng = sec.Range.Endnotes(i).Reference
            rng.Text = i
            rng.Style = "Знак сноски"
        Next i
    Next sec
   
    '7. Сообщение.
    MsgBox "Макрос завершил работу.", vbInformation

End Sub

Private Sub pInsSeparator(rng As Range)
    ' Вставка псевдоразделителя сносок.
    With rng.Borders(wdBorderBottom)
        .LineStyle = wdLineStyleSingle
        .LineWidth = wdLineWidth025pt
        .Color = wdColorAutomatic
    End With
    With rng.ParagraphFormat
        .RightIndent = CentimetersToPoints(12)
        .SpaceBeforeAuto = False
        .SpaceAfterAuto = False
        .SpaceAfter = 6
    End With
End Sub

[свернуть]

[BoomZoom]

Проверил. С моим огромным текстом справился отлично, даже очень быстро.
Уникальная работа! Большое спасибо!

[Посетитель]

Отличный макрос!
Преобразовала его еще и для обычных сносок.
Спасибо!