一个简单的宏实现一键排版（整理复盘）

[TOC]

宏和VBA的区别

• 宏是一个或多个指令的集合，控制word执行一连串的操作
• VBA是高级语言，通过面向对象的方法来完成宏不能完成的工作。
• VBA宏会被VB编辑器记录为一个VBA过程

一键排版宏举例

Sub typeset()
'
' typeset 宏
' Author : 李佳成
' Time : 2018.5.1
'
'
'   清除格式
    Selection.WholeStory
    Selection.ClearParagraphDirectFormatting
    On Error Resume Next
    
'   首行缩进
    
    With Selection.ParagraphFormat
 
        .LeftIndent = CentimetersToPoints(0)
 
        .RightIndent = CentimetersToPoints(0)
 
        .SpaceBefore = 0
 
        .SpaceBeforeAuto = False
 
        .SpaceAfter = 0
 
        .SpaceAfterAuto = False
 
        .LineSpacingRule = wdLineSpaceSingle
 
        .Alignment = wdAlignParagraphJustify
 
        .WidowControl = False
 
        .KeepWithNext = False
 
        .KeepTogether = False
 
        .PageBreakBefore = False
 
        .NoLineNumber = False
 
        .Hyphenation = True
 
        .FirstLineIndent = CentimetersToPoints(0)
 
        .OutlineLevel = wdOutlineLevelBodyText
 
        .CharacterUnitLeftIndent = 0
 
        .CharacterUnitRightIndent = 0
 
        .CharacterUnitFirstLineIndent = 2
 
        .LineUnitBefore = 0
 
        .LineUnitAfter = 0
 
        .MirrorIndents = False
 
        .TextboxTightWrap = wdTightNone
 
        .AutoAdjustRightIndent = True
 
        .DisableLineHeightGrid = False
 
        .FarEastLineBreakControl = True
 
        .WordWrap = True
 
        .HangingPunctuation = True
 
        .HalfWidthPunctuationOnTopOfLine = False
 
        .AddSpaceBetweenFarEastAndAlpha = True
 
        .AddSpaceBetweenFarEastAndDigit = True
 
        .BaseLineAlignment = wdBaselineAlignAuto
 
    End With
    
    
'   清除段落前后空格
    For a = 1 To ActiveDocument.Paragraphs.Count
    Set sutRng = ActiveDocument.Paragraphs(a).Range
    sutRng.MoveEnd wdCharacter, -1
    sutRng.Text = Trim(sutRng.Text)
    sutRng.MoveEnd wdCharacter, 1
    ActiveDocument.Paragraphs(a).Range.Text = sutRng.Text
    Next a
    
'   清除空行，空格
    
    Dim i As Paragraph, n As Long
    Application.ScreenUpdating = False
    For Each i In ActiveDocument.Paragraphs
    If Len(i.Range) = 1 Then
    i.Range.Delete
    n = n + 1
    End If
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "　"
    .Replacement.Text = ""
    .Wrap = wdFindContinue
    End With
    With Selection.Find
    .Text = "vbTab"
    .Replacement.Text = ""
    .Wrap = wdFindContinue
    End With
    With Selection.Find
    .Text = " "
    .Replacement.Text = ""
    .Wrap = wdFindContinue
    End With
    With Selection.Find
        .Text = "^t"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Next
    Application.ScreenUpdating = True
    Options.AutoFormatAsYouTypeDeleteAutoSpaces = True
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = " "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
    Selection.WholeStory
    With ActiveDocument.Styles(wdStyleNormal).Font
        If .NameFarEast = .NameAscii Then
            .NameAscii = ""
        End If
        .NameFarEast = ""
    End With
'   设置页面
    With Selection.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(2.54)
        .BottomMargin = CentimetersToPoints(1.4)
        .LeftMargin = CentimetersToPoints(2.2)
        .RightMargin = CentimetersToPoints(1.3)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.3)
        .FooterDistance = CentimetersToPoints(2)
        .PageWidth = CentimetersToPoints(21)
        .PageHeight = CentimetersToPoints(29.7)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
        .CharsLine = 39
        .LinesPage = 32
        .LayoutMode = wdLayoutModeGrid
    End With
    

        
'   设置段落
    If (ActiveDocument.Paragraphs.Count >= 1) Then
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Selection.MoveLeft unit:=wdCharacter, Count:=1
    Selection.MoveDown unit:=wdParagraph, Count:=1, Extend:=wdExtend
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.Font.Name = "宋体"
    Selection.Font.Bold = wdToggle
    Selection.Font.Size = 22
    Selection.MoveRight unit:=wdCharacter, Count:=1
    End If
    
    If (ActiveDocument.Paragraphs.Count >= 2) Then
    Selection.MoveDown unit:=wdParagraph, Count:=1, Extend:=wdExtend
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    Selection.Font.Name = "宋体"
    Selection.Font.Bold = wdToggle
    Selection.Font.Size = 22
    Selection.MoveRight unit:=wdCharacter, Count:=1
    End If
    
    If (ActiveDocument.Paragraphs.Count >= 3) Then
    Selection.MoveDown unit:=wdParagraph, Count:=ActiveDocument.Paragraphs.Count - 2, Extend:=wdExtend
    Selection.Font.Name = "GB2312"
    Selection.Font.Size = 16
    Selection.MoveRight unit:=wdCharacter, Count:=1
    End If
    
'   加空段落
    ActiveDocument.Paragraphs(2).Range.InsertAfter Chr(13)

'   关键字居中或加粗
    Dim arr_sum(), arr(14), m As Integer, q
    arr(0) = "宣布法庭纪律"
    arr(1) = "宣布开庭"
    arr(2) = "法庭调查"
    arr(3) = "最后陈述"
    arr(4) = "法庭调解"
    arr(5) = "当庭宣判"
    arr(6) = "宣布法庭组成人员和书记员名单"
    arr(7) = "宣布法庭组成人员和书记员名单"
    arr(8) = "告知当事人有关的诉讼权利和义务"
    arr(9) = "诉称部分"
    arr(10) = "答辩部分"
    arr(11) = "法庭归纳争议焦点"
    arr(12) = "当事人举证质证部分"
    arr(13) = "原告举证部分"
    arr(14) = "被告举证部分"
    For m = 0 To 14
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = arr(m)
        .Replacement.Text = ""
        .Format = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    
    s = ActiveDocument.Range(0, Selection.End).Paragraphs.Count
    q = ActiveDocument.Paragraphs(s).Range.Characters.Count
    Selection.Find.Execute
    If Selection.Font.Bold = False Then
        Selection.Font.Bold = wdToggle
    End If
    If m <= 5 Then
    Selection.Font.Size = 18
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End If
    
  
    Next
    
    
'   案由，案号替换格式
    
    Set myRangeb = ActiveDocument.Content
    myRangeb.Find.ClearFormatting
    Dim b As Long
    b = myRangeb.End
    Do While myRangeb.Find.Execute("案号")
    myRangeb.Select
    myRangeb.Text = "案    号"
    myRangeb.Start = myRangeb.Start + Len(myRangeb.Find.Text)
    myRangeb.End = b
    Loop
        
    
    
    
    Set myRangea = ActiveDocument.Content
    myRangea.Find.ClearFormatting
    Dim f As Long
    f = myRangea.End
    Do While myRangea.Find.Execute("案由")
    myRangea.Select
    myRangea.Text = "案    由"
    myRangea.Start = myRangea.Start + Len(myRangea.Find.Text)
    myRangea.End = f
    Loop
    
'   关键字用缩进方式对齐
    Dim arr2(7), j As Integer
    arr2(0) = "人民陪审员："
    arr2(1) = "审判员："
    arr2(2) = "书记员："
    arr2(3) = "有无间断："
    arr2(4) = "其他说明："
    arr2(5) = "结束时间："
    arr2(6) = "原告方："
    arr2(7) = "被告方："
    For j = 0 To 7
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = arr2(j)
        .Replacement.Text = ""
        .Format = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = True
        .MatchWildcards = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft
    Selection.ParagraphFormat.LeftIndent = 165
    If j <= 2 Then
    Selection.ParagraphFormat.LeftIndent = 110
    End If
    If j > 5 Then
    Selection.ParagraphFormat.LeftIndent = 330
    End If
    Next
    

End Sub

完成目标

1. 设置标题及前三段的字体，字号
2. 首行缩进
3. 去除多余空格，制表符，空段
4. 对特殊要求字符进行个别缩进
5. 替换字符
6. 页面设置：页边距，行距，页眉页脚等。

防坑指南

1. 清除格式要求：尽量不要用剪切纯文本方式来清除格式

selection.WholeStory
Selection.ClearParagraphDirectFormatting

2. 程序执行是有顺序的，特别在word中，光标的位置随着程序的执行要注意位置，例如查找字符的时候，特别需要注意。
3. 关键字设置格式，要注意数组越界。