Attribute VB_Name = "Module1"
Public ListWord, ListHTML1, ListHTML2, ListRplHTML, CurStyle, NumCur, WinName
Sub convert()
Dim MyRange
ListWord = Array("normal-article", "normal-innen", "norm-innen", _
    "BodyText", "Heading 1", "Heading 2", "Heading 3", "Heading 4", "Heading 5", "Heading 6", _
    "Normal", "normal-th", "heading TH (4)", "Normal-ZB", "sys com heading 4", "sys com txt 2", _
    "Normal article", "Subhead 2 sys com", "sys com txt 3", "sys com txt 4 italic")
ListHTML1 = Array("<p>", "<li>", "<li>", _
    "<p>", "<h1>", "<h2>", "<h3>", "<h4>", "<h5>", "<h6>", "<p>", "<li>", _
    "<h4 class=th>", "<p class=zb>", "<h4 class=th>", "<p>", "<p>", "<h5>", "<p>", "<p><em>")
ListHTML2 = Array("</p>", "</li>", "</li>", _
    "</p>", "</h1>", "</h2>", "</h3>", "</h4>", "</h5>", "</h6>", "</p>", "</li>", _
    "</h4>", "</p>", "</h4>", "</p>", "</p>", "</h5>", "</p>", "</em></p>")
ListRplHTML = Array("нс", "МГц", "Мбайт", "Мбит", "кГц", "Вт") 'замена побела+ед.измер на неразрыв.пробел+е.изм.
' проверка
    'WinName = ActiveDocument.Name
    'Windows("e.doc").Activate
m1 = UBound(ListWord)
m2 = UBound(ListHTML1)
m3 = UBound(ListHTML2)
If m1 - m2 <> 0 Then Stop
If m1 - m3 <> 0 Then Stop
If m3 - m2 <> 0 Then Stop
i = 0
Call remover
With ActiveDocument
    Selection.HomeKey Unit:=wdStory
    n = .Paragraphs.Count
    For i = 1 To n
        'Set MyRange = ActiveDocument.Paragraphs(i).Range
            Set MyRange = ActiveDocument.Range( _
                Start:=ActiveDocument.Paragraphs(i).Range.Start, _
                End:=ActiveDocument.Paragraphs(i).Range.End)
            MyRange.Select
            
        Selection.HomeKey Unit:=wdLine
        CurStyle = Selection.Style
        Call ListStyle(CurStyle, m1)
        Selection.TypeText Text:=ListHTML1(NumCur)
                    MyRange.Select
        Selection.EndKey Unit:=wdLine
        Selection.TypeText Text:=ListHTML2(NumCur)
       ' i = i + 1
        Selection.MoveDown Unit:=wdLine, Count:=1
    Next
End With
Call ReplHtm
End Sub
Sub remover() ' чиска пробелов
Dim ListBefore, ListAfter

' пробел до знака, два пробела, пробел до знака, два знака

ListBefore = Array(" ", "^p", ",", ".", "?", "!", ":", ";", ")")
ListAfter = Array("^p", "(")
For i = 0 To UBound(ListBefore) 'пробел до знака, два пробела
Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " " + ListBefore(i)
        .Replacement.Text = ListBefore(i)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next i

' пробел после знака

For i = 0 To UBound(ListAfter)
Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ListAfter(i) + " "
        .Replacement.Text = ListAfter(i)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next i

' удвоенные знаки

For i = 0 To UBound(ListBefore) 'пробел+знак, два пробела
Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ListBefore(i) + ListBefore(i)
        .Replacement.Text = ListBefore(i)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next i

End Sub
Sub ReplHtm()

' замена  кавычек

Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = """"
        .Replacement.Text = "&quot;"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

' пробел перед единицей измерения
' "нс", "МГц", "Мбайт", "Мбит", "кГц", "Вт"

For i = 0 To UBound(ListRplHTML)
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " " + ListRplHTML(i)
        .Replacement.Text = "&nbsp;" + ListRplHTML(i)
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next i

'неразрывный пробел

Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^s"
        .Replacement.Text = "&nbsp;"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

End Sub
Sub ListStyle(Stl, m1)
For i = 0 To m1
    If CurStyle = ListWord(i) Then
        NumCur = i
    Else
    End If
Next i
End Sub
Public Sub MAIN()
Dim NumOfFons
Dim i
Dim CurFont$
  WordBasic.FileNew
  NumOfFons = WordBasic.CountFonts()
  ReDim FontNames__$(NumOfFons)
  For i = 1 To NumOfFons
    FontNames__$(i) = WordBasic.[Font$](i)
  Next i
  WordBasic.SortArray FontNames__$()
  WordBasic.Bold 1: WordBasic.FontSize 14: WordBasic.Underline 1
  WordBasic.Insert " Available fonts (Доступные шрифты)" + Chr(13)
  WordBasic.Bold 0: WordBasic.FontSize 12
  For i = 1 To NumOfFons
    CurFont$ = FontNames__$(i)
    WordBasic.Font "Courier New": WordBasic.Underline 1: WordBasic.FormatParagraph LeftIndent:=0
    WordBasic.Insert WordBasic.[LTrim$](Str(i) + ". " + CurFont$ + Chr(13))
    WordBasic.Font CurFont$: WordBasic.FormatParagraph LeftIndent:=20
    WordBasic.Insert "Quick Brown Fox Jumps over the lazy dog" + Chr(13)
    WordBasic.Font CurFont$: WordBasic.FormatParagraph LeftIndent:=20
    WordBasic.Insert "Съешь еще этих мягких французских булочек" + Chr(13)
  Next i
End Sub
Sub replace_dimension()
'
' replace_dimension Macro
' Macro recorded 29.10.2004 by sv
' замена единиц измерения
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " °С"
        .Replacement.Text = "°C" 'rus->en
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " °C"
        .Replacement.Text = "°C" 'en->en
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " Вольта"
        .Replacement.Text = "^sВ"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " Вольт"
        .Replacement.Text = "^sВ"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " Ампера"
        .Replacement.Text = "^sА"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " Ампер"
        .Replacement.Text = "^sА"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " килогерц"
        .Replacement.Text = "^sкГц"
        .Forward = True
        .Wrap = wdFindAsk
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
End Sub