Есть такая задача: документ из разделов, в конце каждого раздела есть концевые сноски.
Нужно все сноски преобразовать в простой текст (а ссылки на сноски - просто в текст в верхнем индексе),
сноски должны располагаться там же - в конце раздела. Мечтой, конечно, было-бы еще и размещение линии сноски, заменив ее просто обычной короткой линией.
То есть получится почти такая же структура текста, только без функционала сносок - только обычный текст.
Нашел что-то близкое, но не то:
Макрос:
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
Выложите файл-пример. Оставьте в этом файле только два раздела.
Чтобы быть уверенным, что мы думаем об одном и том же.
Пример прикладываю (материал авторский - чуть изменил, но суть - та же).
[вложение удалено администратором]
Задача сложная - нельзя узнать отображаемый номер сноски с помощью макроса - нужно производить вычисления.
Могу только попробовать сделать для конкретной ситуации, например, как в вашем примере: в каждом разделе своя нумерация концевых сносок.
Если в каком-то ворд-файле будет сквозная нумерация, то макрос не будет правильно работать.
Ваш вариант решения меня полностью устроит! Сквозной у меня не будет точно!
Посмотрите, всё ли нормально.
Макрос:
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
Огромное преогромное спасибо! Не думал, что это целая программа. Все работает!!! Проверял на огромном тексте (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
Проверил. С моим огромным текстом справился отлично, даже очень быстро.
Уникальная работа! Большое спасибо!
Отличный макрос!
Преобразовала его еще и для обычных сносок.
Спасибо!