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

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

Вот так условие сделайте:
' Если в начале есть две или три русские буквы, а затем не русская буква.
If (text Like "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then

[Anton]

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

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

Создайте короткий файл-пример, запустите на нём макрос, убедитесь, что есть проблема.
А затем запускайте макрос в режиме F8 и смотрите, почему перестаёт работать.

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

В во время режима F8, чтобы проскакивать некоторые моменты, ставьте точку остановки, затем нажимайте на панели зелёную стрелку (Run), когда макрос дойдёт до точки остановки, снова нажимайте F8.

[Anton]

Да я так и делал. Ни в каком-то определенном месте не застревает. А бегает цикл по кругу, около одного и того-же слова. Как-будто не переходит на другую строчку.

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

Для этого макроса можно в ворде  смотреть, что происходит в файле: нажимаете F8, затем переходите в ворд, смотрите, где курсор.

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

У меня такие мысли появляются. Что в каком-то случае у какого-то слова так и остаётся две или три буквы на следующей строке.

[Anton]

Например, зависло у меня на слове "может".

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

А что с ним? У него три буквы перенесено и макрос это не может исправить?

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

Внёс изменения. После вставки слова (это когда макрос расставляет переносы, а затем вставляет сформированное слово в файл), курсор переходил вверх.
Сейчас я сделал, чтобы после этого курсор переходил вниз, на следующую строку.

Для этого макроса нужен ещё ваш макрос "HyphenateWord$".

Макрос

Sub Макрос()
   
    Dim var
   
   
    '1. Поиск в основном тексте.
    Call FindTransports
   
    '2. Поиск в страничных сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '3. Поиск в концевых сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub FindTransports()
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
    Dim word As Range, trans As String
   
   
    '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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
           
                ' Вставка ручных переносов и удаление последнего переноса.
                '1) Присваивание имени "word" перенесённому слову.
                Set word = Selection.Words(1)
                '2) Копирование слова в переменную.
                trans = word.text
                '3) Установка переносов в переменной "trans".
                trans = HyphenateWord$(trans, Chr(31))
                '4) Удаление последнего переноса.
                trans = StrReverse(Replace(StrReverse(trans), Chr(31), "", , 1))
                '5) Вставка слова в файл.
                word.text = trans
               
                ' Запись конца области в переменную.
                lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
               
                ' Переход на следующую строку, т.к. после вставки слова, курсор переходит вверх.
                Selection.Move Unit:=wdLine, Count:=1
               
            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]

Макрос работает! Большое спасибо!

Только вот иногда нет результата.
Скажите, а можно ли как-то отследить, убрался хвост или нет? И, если нет, запретить перенос слов в абзаце, где находилось это слово. Не ожидал, что в текстах так много слов с одним переносом.

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

Макрос

Sub Макрос()
   
    Dim var
   
   
    '1. Поиск в основном тексте.
    Call FindTransports
   
    '2. Поиск в страничных сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If
   
    '3. Поиск в концевых сносках.
    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
        '3) Закрытие области со сносками.
        ActiveWindow.ActivePane.Close
    End If

    '4. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

Sub FindTransports()
   
    ' Selection.MoveDown не используется, т.к. происходил перескок через строку.
        ' Это даже было в самом ворде.
    ' Selection.GoTo не используется, т.к. курсор выходит из области сносок.
   
    Dim text As String, lngEnd As Long
    Dim word As Range, trans As String
   
   
    '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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
           
                ' Вставка ручных переносов и удаление последнего переноса.
                '1) Присваивание имени "word" перенесённому слову.
                Set word = Selection.Words(1)
                '2) Копирование слова в переменную.
                trans = word.text
                '3) Установка переносов в переменной "trans".
                trans = HyphenateWord$(trans, Chr(31))
                '4) Удаление последнего переноса.
                trans = StrReverse(Replace(StrReverse(trans), Chr(31), "", , 1))
                '5) Вставка слова в файл.
                word.text = trans
               
                ' Запись конца области в переменную.
                lngEnd = ActiveDocument.StoryRanges(Selection.StoryType).End - 1
               
                ' Выделение строки и копирование её в переменную "text".
                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 "[а-яё][а-яё][!а-яё]*") Or (text Like "[а-яё][а-яё][а-яё][!а-яё]*") Then
                        ' Отключение автопереноса в этом абзаце.
                        Selection.ParagraphFormat.Hyphenation = False
                        ' Переход в следующую строку, чтобы снять выделение, иначе будет
                            ' выделено две строки.
                        Selection.Move Unit:=wdLine, Count:=1
                    End If
                End If
            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]

Попробуйте пожалуйста у себя позапускать несколько раз макрос с моим примером. У меня не стабильные результаты. То работает, то нет. Не могу понять. И 1 раз из 10 запрещаются переносы в абзаце.
Такой полезный макрос и хочется, чтобы стабильно работал.

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

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

У меня не возникло проблем с вашим файлом. Какие у вас с ним проблемы?
На всякий случай ещё раз возьмите макрос из ответа 41.

[Anton]

У меня то срабатывает, то нет. А от производительности компьютера ничего не может зависеть?