Вставить мягкий перенос в каждое третье слово

@djooj · Регистрация: 19.06.2016

Студворк — интернет-сервис помощи студентам

Помогите пожалуйста! Нужен макрос для вставки мягкого переноса в каждое третье слово текста. Причем желательно чтобы перенос в слове был только один (неважно после какого слога).

@Апострофф · 23.02.2013, 11:46

Сообщение от djooj

(неважно после какого слога)

Вот это самое интересное в задаче - как делить на слоги?

@djooj · 23.02.2013, 14:08

Может быть есть альтернатива решения. Например, расставить мягкие переносы средствами Word, а потом их удалить за исключением переносов в каждом третьем слове?

Добавлено через 2 часа 13 минут
Подскажите пожалуйста, что исправить в этом макросе?
Перенос встаялется ПОСЛЕ каждого пятого слова а нужно чтобы перенос вставлялся в КАЖДОЕ пятое слово

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub ChangeEveryFifthWord()
  Dim i As Long 'Счётчик слов
  Dim oWord As Range 'Текущее слово
  
  'Инициализация переменных
  Set oWord = ActiveDocument.Words.First
  i = 1
  'Перебираем все слова в документе, отсеивая знаки препинания и знаки абзацев.
  Do While i <= ActiveDocument.Words.Count
    
      While Trim(oWord.Text) Like "[.,!?""-]" Or oWord.Text = vbCr
      If oWord.End = ActiveDocument.Words.Last.End Then Exit Sub
      Set oWord = oWord.Next(wdWord)
    Wend
    
    'Если значение счётчика кратно пяти, то изменяем слово
    If i Mod 5 = 0 Then
    oWord.MoveEndWhile " ", wdBackward 'Убираем пробел в конце слова
    Options.AutoFormatAsYouTypeReplaceQuotes = False
    oWord = Chr(31)
    Selection.Find.Execute Replace:=wdReplaceAll
    oWord.HighlightColorIndex = wdYellow 'Подсвечиваем жёлтым
    End If
    
    i = i + 1
    Set oWord = oWord.Next(wdWord)
    If oWord.End = ActiveDocument.Words.Last.End Then Exit Sub
    DoEvents
    
  Loop
End Sub

@Андрэич · 23.02.2013, 14:14

Сообщение от Апострофф

Вот это самое интересное в задаче - как делить на слоги?

Так, видимо: Алгоритм Ляна-Кнута.

@ViterAlex · 24.02.2013, 06:33

Хороший алгоритм у этих Ляна и Кнута. Там же, в обсуждении на хабре есть и упрощённая версия его реализации, доступная для понимания простых смертных. Я перевёл её с Java на VB. Получилось компактнее, как ни странно.

Решение (скопировать и вставить в модуль)

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Option Explicit
 
Public Type HyphenPair
    Pattern As String
    Position As Integer
End Type
 
Dim arHPairs(12) As HyphenPair
Private Const x As String = "йьъ"
Private Const g As String = "аеёиоуыэюяaeiouy"
Private Const s As String = "бвгджзклмнпрстфхцчшщbcdfghjklmnpqrstvwxz"
 
Sub HyphenateEveryThirdWord()
    Dim arHyphPos As Variant
    Dim oRng As Range, nHyphPos As Integer
    Dim sText As String
   On Error GoTo HyphenateEveryThirdWord_Error
 
    Set oRng = ActiveDocument.Words.First
    Dim i As Integer
    i = 1
    
    Do Until oRng Is Nothing
        If Len(Trim(oRng.text)) > 0 Then
            arHyphPos = HyphenPositions(Trim(oRng.text))
            Randomize
            'Случайная позиция вставки переноса
            nHyphPos = Int((UBound(arHyphPos) - 1) * Rnd)
            nHyphPos = arHyphPos(nHyphPos)
            oRng.text = Mid(oRng.text, 1, nHyphPos) & ChrW(31) & Mid(oRng.text, nHyphPos + 1)
            i = i + 3
            
            Set oRng = ActiveDocument.Words(i)
            DoEvents
        End If
    Loop
 
    On Error GoTo 0
    Exit Sub
 
HyphenateEveryThirdWord_Error:
 
End Sub
 
'Номера символов после которых можно вставить переносы
Public Function HyphenPositions(text As String) As Variant
    Dim i As Integer, j As Integer
    Dim sb As String, sText As String
    Dim retval As String
    sText = StrConv(text, vbLowerCase)
    Call Main
    For i = 1 To Len(sText)
        If InStr(x, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "x"
        ElseIf InStr(g, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "g"
        ElseIf InStr(s, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "s"
        End If
    Next
    Dim hp As HyphenPair, index As Integer, actualindex As Integer
    For i = 0 To UBound(arHPairs)
        hp = arHPairs(i)
        index = InStr(sb, hp.Pattern)
        While (index <> 0)
            actualindex = index + hp.Position
            retval = retval & actualindex - 1 - j & ","
            sb = Mid(sb, 1, actualindex - 1) & "-" & Mid(sb, actualindex)
            index = InStr(sb, hp.Pattern)
            j = j + 1 'Счётчик вставленных переносов
        Wend
    Next i
    retval = Mid(retval, 1, Len(retval) - 1)
   HyphenPositions = Split(retval, ",")
End Function
 
Sub Main()
    Dim hp As HyphenPair
    arHPairs(0).Pattern = "xgg": arHPairs(0).Position = 1
    arHPairs(1).Pattern = "xgs": arHPairs(1).Position = 1
    arHPairs(2).Pattern = "xsg": arHPairs(2).Position = 1
    arHPairs(3).Pattern = "xss": arHPairs(3).Position = 1
    arHPairs(4).Pattern = "gsg": arHPairs(4).Position = 1
    arHPairs(5).Pattern = "sgg": arHPairs(5).Position = 2
    arHPairs(6).Pattern = "gssssg": arHPairs(6).Position = 3
    arHPairs(7).Pattern = "gsssg": arHPairs(7).Position = 3
    arHPairs(8).Pattern = "gsssg": arHPairs(8).Position = 2
    arHPairs(9).Pattern = "gssg": arHPairs(9).Position = 2
    arHPairs(10).Pattern = "sgsg": arHPairs(10).Position = 2
    arHPairs(11).Pattern = "sggg": arHPairs(11).Position = 2
    arHPairs(12).Pattern = "sggs": arHPairs(12).Position = 2
End Sub

Функция для расстановки переносов в заданном слове

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Public Function HyphenateWord(ByVal text As String) As String
    Dim i As Integer
    Dim sb As String
    Dim sText As String
    sText = StrConv(text, vbLowerCase)
    Call Main
    For i = 1 To Len(sText)
        If InStr(x, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "x"
        ElseIf InStr(g, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "g"
        ElseIf InStr(s, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "s"
        End If
    Next
    Dim hp As HyphenPair, index As Integer, actualindex As Integer
    For i = 0 To UBound(arHPairs)
        hp = arHPairs(i)
        index = InStr(sb, hp.Pattern)
        While (index <> 0)
            actualindex = index + hp.Position
            sb = Mid(sb, 1, actualindex - 1) & "-" & Mid(sb, actualindex)
            sText = Mid(sText, 1, actualindex - 1) & "-" & Mid(sText, actualindex)
            index = InStr(sb, hp.Pattern)
        Wend
    Next i
    HyphenateWord = sText
End Function

Примеры переносов:

Code
1
2
3
4
?HyphenateWord("Символический")
сим-во-ли-чес-кий
?HyphenateWord("идиосинкразия")
и-ди-о-синк-ра-зи-я

@Андрэич · 24.02.2013, 10:12

Ничего себе... Молодец
+1

Добавлено через 21 минуту

Visual Basic
1
2
3
4
5
6
7
всклизь
порт-ной
а--л-я ф-уршет
фур-шет
во-ис-ти-ну
ра-мам-ба-ха-рам-бэ-ро
за-а-ле-лось

@m-ch · 25.02.2013, 04:00

Решил написать свою функцию по расстановке переносов, идея таже и получилось очень похоже, реализовано все в одной функции, без дополнительных констант, типов и процедур

Pattern взял немного другой, нежели чем у ViterAlex

По идеи, функция должна расставлять переносы не только в отдельном слове, но и в предложении (тексте)

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Function HyphenateWord$(ByVal text$, Optional del$ = "-")
    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

@ViterAlex · 25.02.2013, 06:08

m-ch, твои шаблоны, как и мои, нуждаются в доработке. Попробуй слова "счастье", "йогурт", "оловянный", "чувствовать", "перестройка", "шестнадцать".

Дополненный, изменённый и прокомментированный вариант

Visual Basic
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
Public Type HyphenPair
    Pattern As String
    Position As Integer
End Type
 
Dim arHPairs() As HyphenPair
Private Const x As String = "йьъ"
Private Const g As String = "аеёиоуыэюяaeiouy"
Private Const s As String = "бвгджзклмнпрстфхцчшщbcdfghjklmnpqrstvwxz"
 
Public Function HyphenateWord(ByVal text As String, Optional Delimiter As String = "-", Optional DebugMode As Boolean = False) As String
    Dim i As Integer
    Dim sb As String
    Dim sText As String
    
    sText = StrConv(text, vbLowerCase)
    'Инициализация массива с шаблонами переноса
    Call Main
    
    'Формализация текста по шаблону xgs
    For i = 1 To Len(sText)
        If InStr(x, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "x"
        ElseIf InStr(g, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "g"
        ElseIf InStr(s, Mid(sText, i, 1)) <> 0 Then
            sb = sb & "s"
        End If
    Next
    
    Dim hp As HyphenPair 'Текущий шаблон переноса
    Dim index As Integer 'положение шаблона в формализованном тексте
    Dim actualindex As Integer 'положение переноса в реальном тексте
    Dim FirstMatchFound As Boolean 'Флаг найденного совпадения в формализованном тексте
    Dim patternsBuff As String 'Отладочный буфер для записи сработавших шаблонов
    
    Do
        Dim temp As Integer
        Dim hptemp As HyphenPair
        FirstMatchFound = False
        'Поиск совпадения с шаблоном,
        'расположенного ближе всего к началу формализованного текста
        For i = 0 To UBound(arHPairs)
            hptemp = arHPairs(i)
            temp = InStr(sb, hptemp.Pattern)
            'Поиск первого совпадения
            If Not FirstMatchFound Then
                FirstMatchFound = InStr(sb, hptemp.Pattern)
                index = temp
                hp = hptemp
            End If
            If FirstMatchFound And temp <> 0 Then
                If temp <= index Then
                    index = temp
                    hp = hptemp
                End If
            End If
        Next i
        If index <> 0 Then
            actualindex = index + hp.Position
            'Расстановка переносов в шаблоне
            sb = Mid(sb, 1, actualindex - 1) & Delimiter & Mid(sb, actualindex)
            'Расстановка переносов в тексте
            sText = Mid(sText, 1, actualindex - 1) & Delimiter & Mid(sText, actualindex)
            'Запись сработавшего паттерна
            patternsBuff = patternsBuff & " " & hp.Pattern
        End If
    Loop Until index = 0
    HyphenateWord = sText & IIf(DebugMode, vbCr & patternsBuff, "")
End Function
 
Sub Main()
    Dim hp As HyphenPair
    ReDim arHPairs(16)
    With arHPairs(0): .Pattern = "gssssg": .Position = 2: End With 'чув-ствовать
    With arHPairs(1): .Pattern = "gsssg": .Position = 2: End With 'шест-надцать
    With arHPairs(2): .Pattern = "sgsssg": .Position = 4: End With 'открывать
    With arHPairs(3): .Pattern = "gssxg": .Position = 2: End With 'счас-тье
    With arHPairs(4): .Pattern = "xgsg": .Position = 2: End With 'кой-ка
    With arHPairs(5): .Pattern = "xgg": .Position = 1: End With '?
    With arHPairs(6): .Pattern = "gssg": .Position = 2: End With 'оловян-ный
    With arHPairs(7): .Pattern = "sgsg": .Position = 2: End With 'пе-рестройка
    With arHPairs(8): .Pattern = "sggg": .Position = 2: End With '?
    With arHPairs(9): .Pattern = "sggs": .Position = 2: End With '?
    With arHPairs(10): .Pattern = "xgs": .Position = 2: End With 'йогурт
    With arHPairs(11): .Pattern = "xss": .Position = 1: End With '?
    With arHPairs(12): .Pattern = "sgxsg": .Position = 3: End With 'май-ка
    With arHPairs(13): .Pattern = "gsg": .Position = 1: End With 'а-бажур
    With arHPairs(14): .Pattern = "sgg": .Position = 2: End With 'си-яние
    With arHPairs(15): .Pattern = "sgsssgx": .Position = 2: End With 'пере-стройка
    With arHPairs(16): .Pattern = "sgsxsg": .Position = 4: End With 'малень-кий
End Sub

@m-ch · 25.02.2013, 08:47

Сообщение от ViterAlex

Попробуй слова "счастье", "йогурт", "оловянный", "чувствовать", "перестройка", "шестнадцать"

С "оловянный" вроде все правильно - "оло-вян-ный"

"й" можно из "x" перенести в "s", тогда с "йогуртом" и "йодом" все будет нормально и без дополнительных шаблонов

Сообщение от ViterAlex

m-ch, твои шаблоны, как и мои, нуждаются в доработке

Я не спорю, я их взял по ранее указанной ссылке

В твоих шаблонах, тоже не все нормально:
о-ло-вян-ный
подъе-зд
ин-ту-и-ци-я
по-ртной
йо-д

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

@ViterAlex · 25.02.2013, 08:52

Сообщение от m-ch

В твоих шаблонах, тоже не все нормально:

Согласен. Работаю

Сообщение от m-ch

Пытаясь исправить одну ситуацию ломается другая.

Нужно искать совпадения с начала слова, а не в любом месте + более длинный шаблон должен иметь приоритет. В общем, думать есть над чем

@UUMprimor · 26.08.2020, 13:30

Сообщение от m-ch

Pattern взял немного другой, нежели чем у ViterAlex

и вот так будет точнее:

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

Новые блоги и статьи Все статьи Все блоги /
Символьное дифференцирование igorrr37 13.02.2026 / * Программа принимает математическое выражение в виде строки и выдаёт его производную в виде строки и вычисляет значение производной при заданном х Логарифм записывается как: (x-2)log(x^2+2) -. . .	Камера Toupcam IUA500KMA Eddy_Em 12.02.2026 Т. к. у всяких "хикроботов" слишком уж мелкий пиксель, для подсмотра в ESPriF они вообще плохо годятся: уже 14 величину можно рассмотреть еле-еле лишь на экспозициях под 3 секунды (а то и больше),. . .	И ясному Солнцу zbw 12.02.2026 И ясному Солнцу, и светлой Луне. В мире покоя нет и люди не могут жить в тишине. А жить им немного лет.	«Знание-Сила» zbw 12.02.2026 «Знание-Сила» «Время-Деньги» «Деньги -Пуля»
SDL3 для Web (WebAssembly): Подключение Box2D v3, физика и отрисовка коллайдеров 8Observer8 12.02.2026 Содержание блога Box2D - это библиотека для 2D физики для анимаций и игр. С её помощью можно определять были ли коллизии между конкретными объектами и вызывать обработчики событий столкновения. . . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL_LoadPNG (без SDL3_image) 8Observer8 11.02.2026 Содержание блога Библиотека SDL3 содержит встроенные инструменты для базовой работы с изображениями - без использования библиотеки SDL3_image. Пошагово создадим проект для загрузки изображения. . .	SDL3 для Web (WebAssembly): Загрузка PNG с прозрачным фоном с помощью SDL3_image 8Observer8 10.02.2026 Содержание блога Библиотека SDL3_image содержит инструменты для расширенной работы с изображениями. Пошагово создадим проект для загрузки изображения формата PNG с альфа-каналом (с прозрачным. . .	Установка Qt-версии Lazarus IDE в Debian Trixie Xfce volvo 10.02.2026 В общем, достали меня глюки IDE Лазаруса, собранной с использованием набора виджетов Gtk2 (конкретно: если набирать текст в редакторе и вызвать подсказку через Ctrl+Space, то после закрытия окошка. . .

@djooj 1 / 1 / 0 Регистрация: 19.06.2016 Сообщений: 10

	Вставить мягкий перенос в каждое третье слово 23.02.2013, 11:31. Показов 5758. Ответов 10 Метки перенос по слогам (Все метки) Помогите пожалуйста! Нужен макрос для вставки мягкого переноса в каждое третье слово текста. Причем желательно чтобы перенос в слове был только один (неважно после какого слога). 1