Нахождение слов курсивом и обрамления его в тэги <em>

@tvorex · Регистрация: 07.04.2015

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

Добрый день всем форумчанам...
Мне нужно подготовить небольшое подобие Типографа прямо в ворде.
Споткнулся на шаге, когда нужно соответствующий элемент обрамлять в тэги.

К примеру:

Находим в тексте слова выделенные курсивом и обрамляем их в тэги <em>СловоКурсив</em>
Находим в тексте Заголовок 1 и обрамляем его в тэги <h1>СловоКурсив</h1>
Находим в тексте Заголовок 2 и обрамляем его в тэги <h2>СловоКурсив</h2>

и т.д.

Нашёл в Интернете макрос такого типа:

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
    'Обрамляем слова Курсив тэгами <em>
    Selection.Find.ClearFormatting
    Selection.Find.Font.Italic = True
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
 
    'Если в выделение попал пробел или знак абзаца в конце, то мы его исключаем
    If Right(Selection.Text, 1) = Chr(32) Or _
     Right(Selection.Text, 1) = Chr(13) Then
    Selection.MoveLeft wdCharacter, 1, wdExtend
    End If
    
    'Обрамляем слово тэгами
    With Selection
      .InsertBefore "<em>"
      .InsertAfter "</em>"
    End With

Он хорошо работает, но увы только с одним словом.

Если я правильно понял, нам нужно:

Подсчитать кол-во слов в тексте
Создать коллекцию
Использовать цикл For Each в соответствие кол-ву слов в коллекции

Помогите пожалуйста написать код...
Я больше дизайнер и чуть-чуть верстальщик, но увы, никак не программист VBA

@tvorex · 14.04.2015, 19:45 **[ТС]**

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

Разработчику в помощь: Как создать Закладку в Ворде начиная с цифры?

Sasha_Smirnov, что-то не понял. К чему это?

@Sasha_Smirnov · 15.04.2015, 04:09

Просто переход на похожую тему.

@KoGG · 22.04.2015, 10:42

Решение задачи на 95%.

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
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
Sub ВыделениеСловТегом_через_Find_4()
   'Обрамляем слова тэгами <em>, <strong> , <h1>, <h2>, <h3>, <p>
    Dim k%, TagStart$, TagEnd$, UslNaydeno As Boolean, Ra As Range
    Application.ScreenUpdating = False
    ' Предварительно все символы концов абзаца делаем не жирными и не курсивными.
    Selection.HomeKey wdStory '
    With Selection.Find
        .ClearFormatting
        .Format = True
        .MatchWildcards = False
        .MatchWholeWord = False
        .Forward = True
        .Text = "^p"
        .Wrap = wdFindContinue
        .Font.Italic = True
        .Replacement.ClearFormatting
        .Replacement.Text = "^p"
        .Replacement.Font.Italic = False
        .Replacement.Font.Bold = False
        .Execute Replace:=wdReplaceAll
        .ClearFormatting
        .Font.Bold = True
        .Execute Replace:=wdReplaceAll
    End With
    ' Перебор символов абзацев
    Selection.HomeKey wdStory
    Selection.InsertBefore "<p>"
    Selection.EndKey wdStory
    Selection.MoveLeft Unit:=wdCharacter, Count:=1
    Do
        With Selection.Find
            .Forward = False
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = False
            .Text = "^p"
            .Replacement.Text = "</p>^p<p>"
            .Wrap = wdFindStop
            .Execute
            If .Found Then
                Select Case Selection.Style
                    Case "Заголовок 1", "Заголовок 2", "Заголовок 3"
                    Case Else
                        If Selection.Range.Start > 0 Then
                            .Execute Replace:=wdReplaceOne
                        Else
                            Exit Do
                        End If
                End Select
                Selection.Collapse Direction:=wdCollapseStart
            Else
                Exit Do
            End If
        End With
    Loop
    For k = 0 To 5  ' Перебираем комплекты условий
        Selection.HomeKey wdStory
        With Selection.Find
            .Forward = True
            .ClearFormatting
            .Replacement.ClearFormatting
            .Format = True
            .MatchWildcards = False  ' подстановочные знаки (в диалоге по Ctrl-h) выключены
            .MatchWholeWord = False ' ищем текст из многих слов,
            .Text = ""
            .Wrap = wdFindContinue
            Select Case k
                Case 0 ' поиск по жирному курсиву
                    .Font.Italic = True
                    .Font.Bold = True
                    .Replacement.Font.Italic = False
                    .Replacement.Font.Bold = False
                     TagStart = "<strong><em>"
                     TagEnd = "<\em><\strong>"
                Case 1 ' поиск по жирному
                    .Font.Bold = True
                    .Replacement.Font.Bold = False
                     TagStart = "<strong>"
                     TagEnd = "<\strong>"
                Case 2 ' поиск  курсиву
                    .Font.Italic = True
                    .Replacement.Font.Italic = False
                     TagStart = "<em>"
                     TagEnd = "<\em>"
                Case 3
                    .Style = "Заголовок 1"
                     TagStart = "<h1>"
                     TagEnd = "<\h1>"
                Case 4
                    .Style = "Заголовок 2"
                     TagStart = "<h2>"
                     TagEnd = "<\h2>"
                Case 5
                    .Style = "Заголовок 3"
                     TagStart = "<h3>"
                     TagEnd = "<\h3>"
            End Select
            .Replacement.Font.Color = vbRed  'заменяющий текст делаем красным
            .Replacement.Text = TagStart & "^&" & TagEnd        ' обрамляем текст тэгами
            If .Execute(Replace:=wdReplaceAll) Then UslNaydeno = True
            If k >= 3 Then
                .Replacement.ClearFormatting
                .Format = False
                ' Очистка Заголовков от тегов <p> , </p>
                .Text = "<p>"
                .Replacement.Text = ""
                .Execute Replace:=wdReplaceAll
                .Text = "</p>"
                .Execute Replace:=wdReplaceAll
                ' Перенос тэгов , попавших в чужие абзацы
                .ClearFormatting
                .Text = TagStart & "^p"
                .Replacement.Text = "^p" & TagStart
                .Execute Replace:=wdReplaceAll
                .Text = "^p" & TagEnd
                .Replacement.Text = TagEnd & "^p" & "<p>"
                .Execute Replace:=wdReplaceAll
            End If
        End With
    Next k
    If UslNaydeno Then
        MsgBox "Текст преобразован." & Chr(13) & Chr(13) & _
        "(Ok, Ctrl-z — отмена.)" & Chr(13) & Chr(13) & _
        "Снять весь формат: Ctrl-a, затем Ctrl-Пробел."
    Else:  MsgBox "Нужных слов не найдено."
    End If
End Sub

@tvorex · 24.04.2015, 15:00 **[ТС]**

Добавил:

Visual Basic
1
2
3
4
                Case 6
                    .Style = "Обычный"
                     TagStart = "<p>"
                     TagEnd = "<\p>"

Но тогда у нас получается весь текст красным цветом... Можно сделать исключение для "Обычного" текста?

@KoGG · 24.04.2015, 17:13

Дописать

Visual Basic
1
.Replacement.Font.Color = vbRed

- в каждый случай, кроме 6. Убрать после End Select.
Изменить

Visual Basic
1
 If k >= 3 Then

на

Visual Basic
1
 If k >= 3  And k< 6 Then

Новые блоги и статьи Все статьи Все блоги /
Копировать Windows на новый диск на UEFI damix 17.10.2026 https:/ / uriesk. wordpress. com/ 2016/ 11/ 01/ move-window-10-to-ssd-on-a-uefi-dualboot-system-with-basic-linux-tools/ TL DR Вставляем диск, а старый подключаем через переходник, грузимся с лайва. . .	ИИ не может найти нужный язык в списке Supersumestria 05.10.2026 Я ему даю вот такое изображение и прошу найти и подчеркнуть немецкий язык. Возвращает он вот это: https:/ / i. **********/ vqBWLe2. png Нужную строчку в 3й колонке просто выдумал. . Это. . .	Новая последняя моя музыка в SUNO zorxor 05.10.2026 Здравствуйте, дорогие мои друзья! С большой радостью я хотел бы представить вам свою новую последнею музыку, которую сгенерировала мне по моей просьбе нейросеть SUNO. С уважением, zorxor. Это. . .	Программный домашний кинотеатр russiannick 27.09.2026 Сподобился на программный домашний кинотеатр. В качестве ЯВУ по традиции выбрал js. В помощники взял Яндекс-Алису. Было создано три зала на разные интересы. исторические и ретро сериал Хичкок. . .
Беседа с ИИ о программистах, недопускающих к созданию и правке кода генеративные ИИ и причины этого zorxor 21.09.2026 Раньше я радовался или получал некоторые эмоции, пусть небольшие, но всё же, от самого процесса написания кода, рекомпиляции и запуска, видя постепенное развитие программы и прочее. А теперь лень. . .	Мобильное приложение ColorStep pavlinmavlin 17.09.2026 Реализовал приложение Красный, Зеленый, Синий в Unity3d + c#. Название изменил на ColorStep. Приложение прошло модерацию и теперь доступно для скачивания. Делал его сам, шаг за шагом — и вот,. . .	Запрет дублирования строк в табличной части Maks 13.09.2026 Реализация из решения ниже выполнена на нетиповом справочнике "Нормы ТО" с табличной часть "Виды ТО", разработанного в КА2, со следующими реквизитами: - ВидТО (СправочникСсылка. ВидыТО); - ВидГСМ. . .	Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Jin X 06.09.2026 Скрипты Tampermonkey для CyberForum, ChatGPT, Claude и пр. Работая с форумом и нейросетями в браузере часто хочется что-то подкорректировать или добавить какого-то функционала. Ниже прикреплён. . .

@Sasha_Smirnov 5562 / 1370 / 150 Регистрация: 08.02.2009 Сообщений: 4,109 Записей в блоге: 30
	15.04.2015, 04:09
	Просто переход на похожую тему. 0