Attribute VB_Name = "HTML" Sub SaveInHTML_All() Spiski DvaAbz RemoveHeadings RemoveFonts_html CareChanges SpecialSymbols HtmlAcsessStart Enotes HtmlAcsessEnd Beep End Sub Sub NChange(m1, m2 As String) 'поиск и замена нормальные Selection.Find.ClearFormatting Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = m1 .Replacement.Text = m2 .Forward = True .Wrap = wdFindContinue .Format = True .MatchCase = True .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False ' Do While .Execute .Execute Replace:=wdReplaceAll ' Loop End With Selection.Collapse End Sub Sub WChange(s1, s2 As String) 'поиск и замена с подстановочными символами With Selection.Find .Text = s1 .Replacement.Text = s2 .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = True .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub DvaAbz() NChange "^p^p", "^p" End Sub Sub RemoveHeadings() 'Заменяем стили на таги заголовков 'Как-то выполнена эта задача, но пока получилось только так NombreParas = ActiveDocument.Paragraphs.Count For i = 1 To NombreParas With ActiveDocument.Paragraphs(i).Range Texte$ = .Style Select Case Texte$ Case "Normal", "Normal (Web)", "Обычный", "Обычный (Web)" Texte$ = "p" Case "Заголовок 1" Texte$ = "h1" Case "Заголовок 2" Texte$ = "h2" Case "Заголовок 3" Texte$ = "h3" Case "Заголовок 4" Texte$ = "h4" Case "Заголовок 5" Texte$ = "h5" Case "Заголовок 6" Texte$ = "h6" Case "Заголовок 7" Texte$ = "h7" Case "Заголовок 8" Texte$ = "h8" Case "Заголовок 9" Texte$ = "h9" End Select .InsertBefore "<" & Texte$ & ">" End With Next i 'заменяем на соотв. таги NChange "<Обычный>", "
" NChange "<ОБычный (Web)>", "
" NChange "<Основной текст>", "
" NChange "<Список>", "
" NChange "<Основной текст с отступом 1>", "
" NChange "<Основной текст с отступом 2>", "
" NChange "<Цитата>", "
" NChange "
", "
" 'Заголовок 1 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 1") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 2 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 2") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 3 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 3") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 4 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 4") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 5 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 5") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 6 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 6") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 7 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 7") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Заголовок 8 Selection.Find.ClearFormatting Selection.Find.Style = ActiveDocument.Styles("Заголовок 8") Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Обычный") With Selection.Find .Text = "^p" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub RemoveFonts_html() 'Replace Bold Selection.Find.ClearFormatting Selection.Find.Font.Bold = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Italic Selection.Find.ClearFormatting Selection.Find.Font.Italic = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Underline Selection.Find.ClearFormatting Selection.Find.Font.Underline = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Superscript Selection.Find.ClearFormatting Selection.Find.Font.Superscript = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll 'Replace Subscript Selection.Find.ClearFormatting Selection.Find.Font.Superscript = True Selection.Find.Replacement.ClearFormatting Selection.Find.Replacement.Style = ActiveDocument.Styles("Основной шрифт абзаца") With Selection.Find .Text = "" .Replacement.Text = "^&" .Forward = True .Wrap = wdFindContinue .Format = True End With Selection.Find.Execute Replace:=wdReplaceAll End Sub Sub CareChanges() 'упрощаем и исправляем код 'Для замен заголовков NChange "
", "
" 'Для шрифтовых выделений NChange "^p", "^p" NChange "^p", "^p" NChange "^p", "^p" NChange "^p", "^p" NChange "^p", "^p" NChange "", "" NChange "", "" NChange "", "" NChange "
", "
" NChange "
", "
" NChange "
", "
"
NChange " ", " "
NChange " ^p"
NChange "^l", " номер сноски (назад) текст сноски " _
& "" & i & ""
Selection.EndKey Unit:=wdLine
Selection.Paste
Selection.TypeText " "
ActiveDocument.Endnotes(1).Delete
i = i + 1
Wend
End Sub
"
End Sub
Sub HtmlAcsessStart()
'//////////////
'Помещает обязательные строки в начало документа. Проверяет, если таковые уже существуют
'//////////////
Const HtmlString As String = "" & vbCr
Dim TestRg As Range
Selection.HomeKey Unit:=wdStory
Set TestRg = ActiveDocument.Paragraphs(1).Range
If TestRg.Text <> HtmlString Then
Selection.TypeText "" & vbCr
Selection.TypeText "" & vbCr
Selection.TypeText "" & vbCr
Selection.TypeText Text:="
"
ActiveDocument.Endnotes(1).Range.Select
' вид сноски в документе:
' номер сноски
Selection.Copy
ActiveDocument.Endnotes(1).Reference.Select
Selection.InsertBefore "" _
& "" & i & ""
'идем в конец
Selection.EndKey Unit:=wdStory
Selection.TypeParagraph
' а так выглядит строка в конце:
'