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

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

Можно попробовать увеличивать расстояние между буквами: вкладка "Главная" - группа "Шрифт" - справа еле-заметная стрелка - откроется диалог - вкладка "Дополнительно" - Интервал.

[Anton]

Я об этом думал. Но тогда надо как-то подбирать сжатие или расширение. В коротких абзацах сильное сжатие или расширение испортит однообразие.

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

Макрос будет расширять шрифт в выделенной строке, пока конец строки не изменится.

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

Вы попробуйте расширить текст в том файле, который выкладывали на форуме. Разве сильно заметно?
Может быть в каких-то случаях не будет заметно.

[Anton]

Расширить многое не получится - я вручную делал. Иногда заметно.

Задачу, на мой взгляд, правильнее решать так: нужно в предыдущем слоге установить принудительно перенос (Ctrl - ). Word это поймет и перенесет слово по принудительному переносу. Это будет правильно и изящно. Но как установить такой перенос правильно? А еще, желательно, автоматически? Для меня это из области фантастики.

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

У ворда нет vba-инструментов, чтобы ставить ручные переносы. В макросе есть возможность ставить ручные переносы, но появляется диалог, какой появляется, когда юзер в самом ворде ставит ручные переносы.
То есть у вас только один вариант при установке ручных переносов - использование диалога установки ручных переносов.

[Anton]

А можно ли сделать так, чтобы слово с переносом выделялось? Я тогда попробую взять этот код (где-то нашел давно - не помню где). Может быть, получится? Правда не знаю, как убрать последний перенос в слове. Как думаете, будет работать?
По задумке так: Ваш алгоритм находит слово с переносом, алгоритм ниже расставляет принудительно переносы в слогах, а еще какой-то алгоритм убирает последний принудительный перенос в слове. И тогда получится.

Макрос

Function HyphenateWord$(ByVal text$, Optional del$ = "-")

    ' В аргумент "del" передавайте Chr(31).

    Dim sArr, sPattern, sPosition, i&, j&, k&, m$, sText$

    sArr = Array("йьъ", "аеёиоуыэюяaeiouy", "бвгджзклмнпрстфхцчшщbcdfghjklmnpqrstvwxz")
    sPattern = Split("xgg xgs xsg xss sggsg gssssg gsssg gsssg sgsg gssg sggg sggs")
    sPosition = Array(1, 1, 1, 1, 3, 3, 3, 2, 2, 2, 2, 2)

    sText = text
    For i = 1 To Len(text)
        m = LCase$(Mid$(text, i, 1))
        For j = 0 To UBound(sArr)
            If InStr(sArr(j), m) Then Mid$(text, i, 1) = Mid$("xgs", j + 1, 1): Exit For
        Next j, i

        For i = 0 To UBound(sPattern)
            j = 0
            Do
                k = InStr(j + 1, text, sPattern(i))
                If k Then
                    j = k + sPosition(i)
                    text = Left$(text, j - 1) & del & Mid$(text, j)
                    sText = Left$(sText, j - 1) & del & Mid$(sText, j)
                End If
            Loop While k
        Next i
        HyphenateWord = sText
    End Function

[свернуть]

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

Кроме этого макроса, в этом же модуле или в другом, должна быть ваша функция "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 "[а-яё][а-яё][!а-яё]*" 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
               
            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]

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

[Anton]

Добрый вечер!
Если я ищу в начале не две, а три буквы, то строчка должна быть такой:

If text Like "[а-яё][а-яё][а-яё][!а-яё]*" Then

Но тогда у меня макрос зацикливается. Почему так?

P.S. Или нет, не зацикливается. Не разобрался, потестирую еще.

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

Вы можете сами смотреть проблему.
Перейдите в VBA, поставьте курсор в любое место процедуры "Макрос" и нажимайте клавишу F8.
С каждым нажатием макрос будет двигаться по строкам. Кроме того, в это время вы можете заглядывать в ворд, чтобы посмотреть, что там происходит.

Из зацикливания иногда можно выйти сочетанием клавиш Ctrl+Break. Когда появится диалог, щёлкните Debug и нажимайте клавишу F8, чтобы попытаться понять, почему происходит зацикливание.

Кроме того, в режиме F8 можно наводить курсор на переменные и другие элементы кода и читать, что написано в сплывающей подсказке.

Если нет подсказки, то можно использовать Watch. Для этого нужно выделить интересующее выражение - панель Debug (её надо отобразить) - две команды, связанные с Watch.

[Anton]

Я уже дописал. Спасибо.
Просто хотел изменить алгоритм, чтобы искал или 3 или 2 буквы в начале, но, видимо, напартачил где-то.

[Anton]

Понял, когда зависает. Когда в словах уже есть принудительные переносы (когда 2 раз запускаешь).

[Anton]

Вообщем, так и не смог придумать, как задать условие, чтобы искал 2 или 3 буквы.
Прошу помощи.

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

В режиме F8 нашли строку, на которой зависает? Почему происходит зависание?
Когда зависнет нажмите сочетание клавиш Ctrl+Break и затем нажимайте F8.