Автор неизвестен. Макросы MS-Word для обработки текстов

Макрос для Word 97

Сохранить doc-файл в txt, выделив стили html-тагами
From: Максим Мошков

Sub Libru()
'
' Libru Макрос
' Макрос записан 04.12.00 [e-mail]
'
Selection.Find.ClearFormatting
Selection.Find.Font.Bold = True
Selection.Find.Replacement.ClearFormatting
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 Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Font.Italic = True
Selection.Find.Replacement.ClearFormatting
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 Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Font.Underline = wdUnderlineSingle
Selection.Find.Replacement.ClearFormatting
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 Replace:=wdReplaceAll
Selection.Find.ClearFormatting
With Selection.Find.Font
.Underline = wdUnderlineNone
.StrikeThrough = False
.DoubleStrikeThrough = False
.Superscript = True
.Subscript = False
End With
Selection.Find.Replacement.ClearFormatting
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 Replace:=wdReplaceAll
ChangeFileOpenDirectory "C:\WINDOWS\TEMP\"
ActiveDocument.SaveAs FileName:="C:\BBS\moshkow.txt", FileFormat:=
_
wdFormatText, LockComments:=False, Password:="",
AddToRecentFiles:=True, _
WritePassword:="", ReadOnlyRecommended:=False,
EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False,
SaveAsAOCELetter:= _
False
ActiveDocument.Close
End Sub

Макрос для Word-6

Сохранить doc-файл в txt, выделив стили html-тагами
From: Максим Мошков

Sub MAIN
EditFindFont .Points = "", .Underline = - 1, .Color = - 1, .Strikethrough = - 1, .Superscript = - 1, .Subscript = - 1, .Hidden = - 1, .SmallCaps = - 1, .AllCaps = - 1, .Spacing = "", .Position = "", .Kerning = - 1, .KerningMin = "", .Tab = "0", .Font = "(normal text)", .Bold = - 1, .Italic = 1
EditReplace .Find = "", .Replace = "<i>^&</i>", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 1, .Wrap = 1
EditFindFont .Points = "", .Underline = - 1, .Color = - 1, .Strikethrough = - 1, .Superscript = - 1, .Subscript = - 1, .Hidden = - 1, .SmallCaps = - 1, .AllCaps = - 1, .Spacing = "", .Position = "", .Kerning = - 1, .KerningMin = "", .Tab = "0", .Font = "(normal text)", .Bold = 1, .Italic = - 1
EditReplace .Find = "", .Replace = "<b>^&</b>", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 1, .Wrap = 1
EditFindFont .Points = "", .Underline = 1, .Color = - 1, .Strikethrough = - 1, .Superscript = - 1, .Subscript = - 1, .Hidden = - 1, .SmallCaps = - 1, .AllCaps = - 1, .Spacing = "", .Position = "", .Kerning = - 1, .KerningMin = "", .Tab = "0", .Font = "(normal text)", .Bold = - 1, .Italic = - 1
EditReplace .Find = "", .Replace = "<u>^&</u>", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 1, .Wrap = 1
EditFindFont .Points = "", .Underline = - 1, .Color = - 1, .Strikethrough = - 1, .Superscript = 1, .Subscript = 0, .Hidden = - 1, .SmallCaps = - 1, .AllCaps = - 1, .Spacing = "", .Position = "", .Kerning = - 1, .KerningMin = "", .Tab = "0", .Font = "(normal text)", .Bold = - 1, .Italic = - 1
EditReplace .Find = "", .Replace = "^{[^&]}", .Direction = 0, .MatchCase = 0, .WholeWord = 0, .PatternMatch = 0, .SoundsLike = 0, .ReplaceAll, .Format = 1, .Wrap = 1
ChDefaultDir "E:\", 0
FileSaveAs .Name = "MOSHKOW.TXT", .Format = 2, .LockAnnot = 0, .Password = "", .AddToMru = 1, .WritePassword = "", .RecommendReadOnly = 0, .EmbedFonts = 0, .NativePictureFormat = 0, .FormsData = 0
End Sub

Убирание лишних переводов строк и пробелов в абзацев

From: [e-mail]

Sub Probel()
Dim i As Long

For i = 1 To 100 'Как узнать число символов в тексте :(
'Сервис => Статистика => Число символов

nex:
Selection.Move
If (Selection.Text = " ") Then
Selection.Move Unit:=wdCharacter, Count:=-1
If (Selection.Text = " ") Then
Selection.Delete Unit:=wdCharacter, Count:=1
Else
Selection.Move
i = i + 1
End If
End If
If (Selection.Text = Chr$(13)) Then
Selection.Move Unit:=wdCharacter, Count:=1
i = i + 1
If (Selection.Text = Chr$(13)) Then
Selection.Move Unit:=wdCharacter, Count:=1
i = i + 1
GoTo nex
End If

If (Selection.Text = "@") Then
Selection.Move Unit:=wdCharacter, Count:=-1
i = i - 1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
i = i + 3
GoTo nex
End If

If (Selection.Text <> " ") Then
Selection.Move Unit:=wdCharacter, Count:=-1
i = i - 1
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.InsertAfter (" ")

Else
Selection.Move Unit:=wdCharacter, Count:=2
i = i + 2
If (Selection.Text <> " ") Then
Selection.Move Unit:=wdCharacter, Count:=1
i = i + 1
End If
End If

End If
Next
End Sub