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

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

 
  • Макросы MS-Word для обработки текстов
  • Макрос для Word 97
  • Макрос для Word-6
  • Убирание лишних переводов строк и пробелов в абзацев


  • Макрос для 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


    Home | UK Shop Center |Contact | Buy Domain | Directory | Web Hosting | Resell Domains


    Copyleft 2005 ruslib.us