Word Макросы: Исправить поврежденные сноски

[Anton]

Добрый день! Подскажите пожалуйста, как исправить ситуацию со сносками.

Первый файл
Здесь знак сноски в основном тексте выглядит как просто текст, но ворд считает такую сноску сноской. Нужно преобразовать такой знак сноски в обычный знак сноски, окружённый пунктирной границей. Пунктирную границу видно в режиме непечатаемых символов.

Второй файл
Здесь знаки сносок в области сносок просто напечатаны от руки. Нужно их заменить на обычные знаки сноски, чтобы знаки сносок были окружены пунктирной границей. Пунктирную границу видно в режиме непечатаемых символов.

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

Макрос работает при условии, что в области сносок, после псевдознака сноски есть пробел (обычный или неразрывный).
Если пробела нет, то макрос удалит нужный текст до первого пробела или если в абзаце нет пробелов, то произойдёт ошибка во время работы макроса.

Поместите все три процедуры в один модуль. Запускайте процедуру "макрос".

Макрос

Sub макрос()

    '1. Отключение монитора (может это ускорит макрос и чтобы не мерцало).
    Application.ScreenUpdating = False
   
    '2. Изменение номеров сносок в основном тексте.
    '1) Работа со страничными сносками.
    ChangeMainArea ActiveDocument.Footnotes
    '2) Работа с концевыми сносками.
    ChangeMainArea ActiveDocument.Endnotes
   
    '3. Изменение номеров сносок в области сносок.
    '1) Работа со страничными сносками.
    ChangeNotesArea ActiveDocument.Footnotes
    '2) Работа с концевыми сносками.
    ChangeNotesArea ActiveDocument.Endnotes
   
    '4. Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

Private Sub ChangeMainArea(notes As Object)

    ' Изменение номеров сносок в основном тексте.
        ' Есть случаи, когда номер сноски не в виде специального символа,
        ' внутри пунктирной границы, а просто в виде числа. Но это не
        ' просто псевдосноска, т.к. ворд распознаёт такую сноску, как сноску.
   
    Dim note As Object, i As Long
   
    ' Если нет сносок, то выход из процедуры.
    If notes.Count = 0 Then
        Exit Sub
    End If
   
    ' Нужно двигаться от последней к первой, иначе что-то непонятное происходит.
        ' Наверное, происходит удаление сноски и создание новой.
    For i = notes.Count To 1 Step -1
        ' Присваиваем сноке имя "note", чтобы было удобно писать и читать код.
        Set note = notes(i)
        ' Если сноска не имеет пунктирного обрамления.
        If Asc(note.Reference.text) <> 2 Then
            ' Вставка сноски прямо в имеющуюся сноску.
            note.Reference.Footnotes.Add Range:=note.Reference, Reference:=""
        End If
    Next i
       
End Sub

Private Sub ChangeNotesArea(notes As Object)

    ' Изменение номеров сносок в области сносок.
   
    Dim note As Object, rng As Range
   
    ' Если нет сносок, то выход из процедуры.
    If notes.Count = 0 Then
        Exit Sub
    End If
   
    For Each note In notes
        If Asc(note.Range.Paragraphs(1).Range.Characters(1).text) <> 2 Then
            note.Reference.Copy
            Set rng = note.Range.Paragraphs(1).Range.Characters(1)
            ' Движение конца фрагмента до пробела.
            rng.MoveEndUntil Cset:=" " & Chr(160)
            rng.PasteAndFormat wdFormatOriginalFormatting
        End If
    Next note
       
End Sub

[свернуть]

[Anton]

Здорово! Работает! Спасибо за помощь!