Word Макрос: Запретить перенос заданного количества букв

[Anton]

Добрый день!
А возможно ли написать макрос, который запрещает перенос в слове, если у слова на следующую строку переносится 2 буквы (например, в слове "компетенцией", может перенестись -ей).

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

У вас в ворд-файле какие переносы сейчас: автоматические или ручные? Под ручными я понимаю не просто что юзер печатает дефисы внутри слова, а которые вставляются вордом.

[Anton]

Разметка страницы - Расстановка переносов - Авто. У меня всегда так.

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

Если в самом ворде нет такой настройки, то и как правило и в макросе нет такой настройки.
Чтобы в вашем случае контролировать переносы, надо отключить в абзаце автопереносы и затем вам надо вручную расставить переносы так, как вам надо.
Ручные переносы макрос расставляет тоже с помощью диалога.

[Anton]

Понятно. Спасибо.

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

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

Макрос работает в основной части файла и во всех видах сносок. Таблицы не обрабатываются.
Макрос работает только с автоматическими переносами; такие переносы видны на мониторе (в виде дефиса), но фактически дефисов нет.

Макрос. Версия от 05.03.2017 0:37

Sub Макрос1()
   
    Dim text As String, found As Boolean
   
   
    '1. Установка текстового курсора в начало файла.
    Selection.HomeKey Unit:=wdStory
   
    '2. Цикл по строкам.
    Do
        ' Если курсор в таблице, то выход из таблицы.
        If Selection.Information(wdWithInTable) = True Then
            Selection.Tables(1).Range.Characters.Last.Next.Select
        End If
        ' Выделение строки и копирование её текста в переменную.
        Selection.Expand Unit:=wdLine
        text = LCase(Selection.text)
        ' Если справа буква, значит есть автоперенос текста.
        If Right(text, 1) Like "[а-яё]" Then
            ' Переход в нижнюю строку и копирование её текста в переменную.
            Selection.MoveDown Unit:=wdLine, Count:=1
            Selection.Expand Unit:=wdLine
            text = LCase(Selection.text)
            ' Если в начале есть две русские буквы, а затем не русская буква.
            If text Like "[а-яё][а-яё][!а-яё]*" Then
                ' Закраска.
                Selection.Range.HighlightColorIndex = wdYellow
                ' Пометка.
                found = True
            End If
        Else
            ' Без этого бесконечный цикл на последней строке.
            Selection.EndKey
            ' Переход на следующую строку.
            If Selection.MoveDown(Unit:=wdLine, Count:=1) = 0 Then
                Exit Do
            End If
        End If
    Loop

   
    '3. Сообщение.
    If found = True Then
        MsgBox "Найдено.", vbExclamation
    Else
        MsgBox "Не найдено.", vbInformation
    End If
   
End Sub

[свернуть]

[Anton]

Большое спасибо! Оригинальное решение. Протестирую.

[Anton]

Протестировал. Почему-то выделяются не все строки.
Пример приложил.

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

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

Тут даже дело не в макросе, а сам ворд ведёт себя неадекватно.
Выделите первую строку в файле, который вы прикрепили, и нажмите клавишу-стрелку-вниз (это делает макрос). Курсор перейдёт в строку 3, а должен перейти в строку 2. То есть брак в программе "Word".
Предполагаю, что нужно делать отдельно макрос для основного текста и отдельно для сносок.
Вам нужно отслеживать переносы в сносках?

[Anton]

Сноски тоже нужно обрабатывать. У меня иногда они по половине страницы занимают. И такой макрос здорово выручал бы.

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

Макрос. Версия от 06.03.2017 14:01

Sub Макрос()
   
    Dim founds(1 To 3) As String, var
   
   
    '1. Заполнение массива "founds" исходными данными.
    founds(1) = "нет"
    founds(2) = "нет"
    founds(3) = "нет"
   
    '2. Поиск в основном тексте.
    Call FindTransports(founds(1))
   
    '3. Поиск в страничных сносках.
    If ActiveDocument.Footnotes.Count > 0 Then
        '1) Отображение снизу области со всеми страничными сносками.
            ' При этом курсор переходит в эту область.
        ' Запоминаем, сколько отображается областей, чтобы понять, открылась область со сносками
            ' или закрылась, т.к. команда ниже делает и то и другое в зависимости от ситуации.
        var = ActiveWindow.Panes.Count
        ' Отображение области со сносками.
        ActiveWindow.View.SplitSpecial = wdPaneFootnotes
        ' Проверяем, закрылась область или открылась. Если закрылась, то ещё раз открываем.
        If ActiveWindow.Panes.Count < var Then
            ' Отображение области со сносками.
            ActiveWindow.View.SplitSpecial = wdPaneFootnotes
        End If
        '2) Поиск.
        Call FindTransports(founds(2))
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '4. Поиск в концевых сносках.
    If ActiveDocument.Endnotes.Count > 0 Then
        '1) Отображение снизу области со всеми концевыми сносками.
        var = ActiveWindow.Panes.Count
        ActiveWindow.View.SplitSpecial = wdPaneEndnotes
        If ActiveWindow.Panes.Count < var Then
            ActiveWindow.View.SplitSpecial = wdPaneEndnotes
        End If
        '2) Поиск.
        Call FindTransports(founds(3))
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '5. Сообщение.
    MsgBox _
        "1) основной текст: " & founds(1) & vbCr & _
        "2) страничные сноски: " & founds(2) & vbCr & _
        "3) концевые сноски: " & founds(3), vbInformation

End Sub

Sub FindTransports(found As String)
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
   
   
    '1. Установка текстового курсора в начало области (RangeStory).
    Selection.HomeKey Unit:=wdStory
   
    '2. Запись конца области в переменную.
    lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
   
    '3. Цикл по строкам.
    Do
   
        ' Если курсор в таблице, то выход из таблицы.
        If Selection.Information(wdWithInTable) = True Then
            Selection.Tables(1).Range.Characters.Last.Next.Select
        End If
       
        ' Выделение строки и копирование её текста в переменную.
        Selection.Expand Unit:=wdLine
        text = LCase(Selection.text)
       
        ' Если справа буква, значит есть автоперенос текста.
        If Right(text, 1) Like "[а-яё]" Then
            ' Переход в нижнюю строку и копирование её текста в переменную.
            Selection.Move Unit:=wdLine, Count:=1
            Selection.Expand Unit:=wdLine
            text = LCase(Selection.text)
            ' Если в начале есть две русские буквы, а затем не русская буква.
            If text Like "[а-яё][а-яё][!а-яё]*" Then
                ' Закраска.
                Selection.Range.HighlightColorIndex = wdYellow
                ' Пометка.
                found = "ДА"
            End If
        Else
            ' Переход на следующую строку.
            Selection.Move Unit:=wdLine, Count:=1
            ' Если достигнут конец области.
                ' С помощью самого "Move" не получается узнать, достигнут ли конце области,
                ' т.к. используется выделение строки и ворд всегда считает, что произошёл переход
                ' на следующую строку (брак в ворде).
            If Selection.End = lngEnd Then
                Exit Sub
            End If
        End If
       
    Loop
   
End Sub

[свернуть]

[Anton]

Огромное спасибо!
На документе 130 листов (размер шрифта 12, одинарный интервал) отработал очень даже быстро! И я не ожидал, что таких "хвостов" у меня так много!

Уже начал думать, как автоматом убрать хвосты. Но пока ничего не придумал.
Но, все-равно, очень выручили!

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

Если в одном месте хвост уберёте, то дальше в файле могут появиться хвосты. Поэтому после изменения может потребоваться снова запускать макрос.

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

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

[Anton]

Пробелы не подойдут. Наоборот, от лишних избавляюсь.