Оцените этот текст:Не читал10987654321
СодержаниеFine HTMLPrinted versiontxt(Word,КПК)Lib.ru html
Макросы MS-Word для обработки текстов


Макрос для Word 97

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

Sub Libru()
'
' Libru Макрос
' Макрос записан 04.12.00 moshkow@ipsun.ras.ru
'
    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 = "<sup>[^&]</sup>", .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: Aquary@mail.ru

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
Last-modified: Wed, 20 Dec 2000 18:59:23 GMT
Оцените этот текст:Не читал10987654321