使用Word VBA 批量排版报告

排版要求：

主题目采用“二号 宋体 加粗”
全文采用宋体，数字及英文字母采用“Times New Roman”字体。字号均为小四。
一级“宋体 三号 加粗”。二级、三级标题采用“宋体 四号 加粗”
行间距为“多倍行距1.2倍” 首行缩进两字符， 两端对齐
段前段后间距为0 部分，以美观为主，可适当调整。
表格内文字采用五号，表格上标题采用为五号，加粗
图片下标题采用为五号，加粗
附件2表格文字也采用五号。
三个附件重新从“1”开始编页码。直到最后一页。
目录标题 宋体三号加粗
一级标题 四号 加粗 二级、三级为五号 依次空两格
行间距为“多倍行距1.2倍

但是存在一个问题：待处理的文档必须提前将段落间距调整为0行或0磅，否则代码对段落间距不起作用，没想明白原因。

Sub 调整格式()
    Dim t
    t = Timer
    
    Dim vDirectory As String
    Dim theParagraph As Paragraph, theStr$
    Dim reg As Object
    Dim wrs As Characters

    Dim oDoc As Document
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择待处理文件所在的文件夹"
        .InitialFileName = "c:\"
        If .Show Then
            vDirectory = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    vFile = Dir(vDirectory & "*.*", vbNormal)
    Dim par As Paragraph
    Dim tabl As Table
    Do While vFile <> ""
        Application.ScreenUpdating = False
        Set oDoc = Documents.Open(FileName:=vDirectory & vFile)
        '设置文档页面
        With oDoc.PageSetup
            .Orientation = wdOrientPortrait
            .PageWidth = CentimetersToPoints(21)
            .PageHeight = CentimetersToPoints(29.7)
            .TopMargin = CentimetersToPoints(2.5)
            .BottomMargin = CentimetersToPoints(2.5)
            .LeftMargin = CentimetersToPoints(2.5)
            .RightMargin = CentimetersToPoints(2.5)
            .HeaderDistance = CentimetersToPoints(1)
            .FooterDistance = CentimetersToPoints(0.5)
        End With
        oDoc.Select
        With Selection
            .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
            .ParagraphFormat.SpaceBeforeAuto = False
            .ParagraphFormat.SpaceAfter = 10
            .ParagraphFormat.SpaceBefore = 10
            .Range.Font.Name = "宋体" '设置正文中文字体为宋体
            .Range.Font.Name = "Times New Roman" '设置正文英文和数字字体为宋体
            .Range.Font.Size = 12 '设置正文字号为小四号
            .Range.Font.Bold = False
            .ParagraphFormat.LineSpacingRule = wdLineSpaceMultiple
            .ParagraphFormat.LineSpacing = LinesToPoints(1.2)
       
        End With
        

        For Each par In oDoc.Paragraphs
           '根据大纲级别，单独设置其字号并加粗
            If (par.OutlineLevel = wdOutlineLevel1) Then
                par.Range.Font.Bold = True
                par.Range.Font.Size = 16
               
            ElseIf (par.OutlineLevel = wdOutlineLevel2 Or par.OutlineLevel = wdOutlineLevel2) Then
                par.Range.Font.Bold = True
                par.Range.Font.Size = 14
              
             End If
        Next
        
        '设置表格样式
        For Each tabl In oDoc.Tables
            tabl.AutoFitBehavior (wdAutoFitWindow)
            tabl.Borders.OutsideLineStyle = wdLineStyleSingle
            tabl.Borders.OutsideLineWidth = wdLineWidth025pt
            tabl.Range.Rows.Alignment = wdAlignRowCenter
            tabl.Select
            Selection.Font.Size = 10.5
            Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
            Selection.MoveUp wdLine, 1, wdMove
            Selection.EndKey wdLine, wdExtend
            Selection.Font.Size = 10.5
            Selection.Font.Bold = True
        Next
        
      '设置图片标题样式  
    Set reg = CreateObject("VBScript.RegExp")
        With reg
            .Pattern = "^图\d+\s+"
            For Each theParagraph In oDoc.Paragraphs
                theStr = theParagraph.Range
                If .test(theStr) Then
                    theParagraph.Range.Font.Bold = True
                     theParagraph.Range.Font.Size = 10.5
                End If
            Next
        End With
        Set reg = Nothing
        '设置目录样式
        oDoc.TablesOfContents(1).Range.Select
        For Each wrd In Selection.Characters
            With wrd
                If (.Font.Bold = True) Then
                    .Font.Size = 14
                Else
                 .Font.Size = 10.5
                 .Font.Underline = False
                End If
            End With
        Next
        
        oDoc.Save
        oDoc.Close
        vFile = Dir
    Loop
    MsgBox ("已全部处理完毕共用时" & Timer - t & "秒")
End Sub