word vba自动化排版-设置标题模板样式、标题、正文、图表、页面、上下标等设置、删除空白行、删除分页符分节符、删除空格等

word vba自动化排版-设置标题模板样式、标题、正文、图表、页面、上下标等设置、删除空白行、删除分页符分节符、删除空格等

目录

1.前提

2.思路

3.word中设置

4.效果图

5.经验教训

6.直接上代码

---

1.前提

        需求：工作中涉及自动识别大量的文字报告（ocr完成），然后对报告进行排版，手动排版效率超级慢，因此探索了一下word vba自动排版

        参考：chatgpt、word vba官网文档、这篇博客csdn、这篇博客知乎、还有上下标的博客不知出处

        注意：不要期望别人都给代码注释好这个参数、这个函数是什么作用什么意思，像CentimetersToPoints、CharacterUnitFirstLineIndent等等，去官网文档查看一下才最有深刻印象。

着重理解官网文档selection、activedocument的关联，以及word 对象之间的关联（主要看对象属性里面有哪些 跳转一下查看），像inlinshape.range.ParagraphFormat嵌入式图片的段落样式设置等等。。。

2.思路

       先了解一下基础语法！

        ①对于标题模板样式、段落文字的样式设置 主要用录制宏来实现，基于此修改代码

        ②对于find、段落、document、selection等的函数参数要去官网查看文档

        ③对于删除分页符等参考的chatgpt，国内的大模型不行

        ④对于上下标，参考的不知出处的博客-感谢

        ⑤设置图表样式 参考官网、博客、chatgpt

        录制宏不是万能的，对于删除分页符、设置图表样式这样的操作，录制宏的代码单独执行不起作用！

        若想精通熟练使用vba进行排版，还是需要去官网了解vba的对象结构，以及函数用法。

        直接上手用，若复杂操作会比较依赖chatgpt，实际上很多参数不知道啥作用，查看官方文档需要较长时间理解。

        代码可以在wps中运行，但是样式有的不尽人意。

3.word中设置

        ①先设置 开发工具：文件->选项->信任中心设置->启用宏

        ②打开 开发工具->vb编辑器->工具->引用->勾选“Microsoft VBScript Regular Expressions 5.5”

4.效果图

        TODO

5.经验教训

        ①对于段落（非图表）参数越多越好，参数之间会互相影响（使用录制宏）

        ②对于图表，参数不一定越多越好，有的参数互相影响，导致效果有问题

6.直接上代码

        涉及：设置标题图片模板样式、标题、正文、图表、页面、上下标等样式、删除空白行、删除分页符分节符、删除空格等

Sub 设置标题正文模板样式1()
'
' 设置标题正文模板样式 宏
' 设置2级标题、正文的字体段落、图片样式模板
'
    With ActiveDocument.Styles(wdStyleHeading2).Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "Times New Roman"
        .Name = "Times New Roman"
        .Size = 22
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 1
        .Animation = wdAnimationNone
        .DisableCharacterSpaceGrid = False
        .EmphasisMark = wdEmphasisMarkNone
        .Ligatures = wdLigaturesNone
        .NumberSpacing = wdNumberSpacingDefault
        .NumberForm = wdNumberFormDefault
        .StylisticSet = wdStylisticSetDefault
        .ContextualAlternates = 0
    End With
    With ActiveDocument.Styles(wdStyleHeading2).ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .WidowControl = False
        .KeepWithNext = False
        .KeepTogether = True
        .PageBreakBefore = True
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevel2
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
        .CollapsedByDefault = False
        .AutoAdjustRightIndent = True
        .DisableLineHeightGrid = False
        .FarEastLineBreakControl = True
        .WordWrap = True
        .HangingPunctuation = True
        .HalfWidthPunctuationOnTopOfLine = False
        .AddSpaceBetweenFarEastAndAlpha = True
        .AddSpaceBetweenFarEastAndDigit = True
        .BaseLineAlignment = wdBaselineAlignAuto
    End With
    ActiveDocument.Styles(wdStyleHeading2).NoSpaceBetweenParagraphsOfSameStyle = False
    With ActiveDocument.Styles(wdStyleHeading2)
        .AutomaticallyUpdate = False
        .BaseStyle = wdStyleNormal
        .NextParagraphStyle = wdStyleNormal
    End With

    '新建 图片样式 判断是否存在
    On Error Resume Next  ' 暂时禁用错误处理
    styleExists = Not (ActiveDocument.Styles("图片样式") Is Nothing)
    On Error GoTo 0       ' 恢复正常的错误处理

    If Not styleExists Then
        ActiveDocument.Styles.Add Name:="图片样式", Type:=wdStyleTypeParagraph
    End If
    
    ActiveDocument.Styles("图片样式").AutomaticallyUpdate = True
    With ActiveDocument.Styles("图片样式").Font
        .NameFarEast = "宋体"
        .NameAscii = "Times New Roman"
        .NameOther = "Times New Roman"
        .Name = "Times New Roman"
        .Size = 10.5
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 1
        .Animation = wdAnimationNone
        .DisableCharacterSpaceGrid = False
        .EmphasisMark = wdEmphasisMarkNone
        .Ligatures = wdLigaturesNone
        .NumberSpacing = wdNumberSpacingDefault
        .NumberForm = wdNumberFormDefault
        .StylisticSet = wdStylisticSetDefault
        .ContextualAlternates = 0
    End With
    With ActiveDocument.Styles("图片样式").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 0
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceSingle
        .Alignment = wdAlignParagraphCenter
        .WidowControl = False
        .KeepWithNext = True
        .KeepTogether = True
        .PageBreakBefore = True
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .OutlineLevel = wdOutlineLevelBodyText
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
        .CollapsedByDefault = False
        .AutoAdjustRightIndent = True
        .DisableLineHeightGrid = False
        .FarEastLineBreakControl = True
        .WordWrap = True
        .HangingPunctuation = True
        .HalfWidthPunctuationOnTopOfLine = False
        .AddSpaceBetweenFarEastAndAlpha = True
        .AddSpaceBetweenFarEastAndDigit = True
        .BaseLineAlignment = wdBaselineAlignAuto
    End With
    ActiveDocument.Styles("图片样式").NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("图片样式").ParagraphFormat.TabStops.ClearAll
    With ActiveDocument.Styles("图片样式").ParagraphFormat
        With .Shading
            .Texture = wdTextureNone
            .ForegroundPatternColor = wdColorAutomatic
            .BackgroundPatternColor = wdColorAutomatic
        End With
        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        .Borders(wdBorderRight).LineStyle = wdLineStyleNone
        .Borders(wdBorderTop).LineStyle = wdLineStyleNone
        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        With .Borders
            .DistanceFromTop = 1
            .DistanceFromLeft = 4
            .DistanceFromBottom = 1
            .DistanceFromRight = 4
            .Shadow = False
        End With
    End With
    ActiveDocument.Styles("图片样式").Frame.Delete
    
    MsgBox "标题正文模板样式设置完成"
End Sub


Sub 设置页面参数2()
'
'设置初始化：取消所有样式、设置页边距、设置纸张大小、页眉页脚边距、每页行数、每行字数、设置所有段落为正文样式
'
    Selection.WholeStory
    Selection.ClearFormatting
    Selection.Range.HighlightColorIndex = wdNoHighlight
    
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = CentimetersToPoints(2.54)
        .BottomMargin = CentimetersToPoints(2.54)
        .LeftMargin = CentimetersToPoints(3.17)
        .RightMargin = CentimetersToPoints(3.17)
        .Gutter = CentimetersToPoints(0)
        .HeaderDistance = CentimetersToPoints(1.5)
        .FooterDistance = CentimetersToPoints(1.75)
        .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 = 44
        .LayoutMode = wdLayoutModeGrid
    End With
    ' 设置正文样式
    Selection.Style = ActiveDocument.Styles(wdStyleNormal)
    
    Selection.HomeKey Unit:=wdStory
    MsgBox "页面参数样式设置完成"

End Sub


Sub 删除空白行3()
'
'先执行删除空白行（不可等设置完样式后再执行），再将全文所有空格删除
'
    Dim para As Paragraph
    Dim isBlank As Boolean
    
    For Each para In ActiveDocument.Paragraphs
        isBlank = True
        If Len(para.Range.text) <> 1 Then
            isBlank = False
        End If
        
        If para.Range.Information(wdWithInTable) = False Then
            If isBlank Then
                para.Range.Delete
            End If
        End If
    Next
    ActiveDocument.Content.Find.Execute FindText:=" ", ReplaceWith:="", Replace:=wdReplaceAll
    MsgBox "已删除所有空白行（非表格内）、空格"
End Sub

Sub 删除分页符4_1()
'chatgpt生成 需要去了解While .Execute用法、Collapse 等
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Selection.HomeKey Unit:=wdStory
    Dim rng As Range
    Set rng = ActiveDocument.Content

    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = True
        .pattern = "\d+"
    End With
    With rng.Find
        .ClearFormatting
        .text = "^m"
        .Forward = True
        .Wrap = wdFindStop

        While .Execute
            Dim lineText As String
            lineText = rng.Paragraphs(1).Range.text

            If regEx.test(lineText) Then
                Dim matches As Object
                Set matches = regEx.Execute(lineText)
                If matches.Count > 0 Then
                    rng.Paragraphs(1).Range.Delete
                End If
            End If

            rng.Collapse Direction:=wdCollapseEnd
            rng.MoveStart Unit:=wdCharacter, Count:=1
        Wend
    End With
    
End Sub

Sub 删除分节符4_2()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Selection.HomeKey Unit:=wdStory
    Dim rng As Range
    Set rng = ActiveDocument.Content

    Dim regEx As Object
    Set regEx = CreateObject("VBScript.RegExp")
    With regEx
        .Global = True
        .pattern = "\d+"
    End With

    With rng.Find
        .ClearFormatting
        .text = "^b"
        .Forward = True
        .Wrap = wdFindStop

        While .Execute

            Dim lineText As String
            lineText = rng.Paragraphs(1).Range.text

            If regEx.test(lineText) Then
                Dim matches As Object
                Set matches = regEx.Execute(lineText)
                If matches.Count > 0 Then
                    rng.Paragraphs(1).Range.Delete
                End If
            End If

            rng.Collapse Direction:=wdCollapseEnd
            rng.MoveStart Unit:=wdCharacter, Count:=1
        Wend
    End With
    
    ActiveDocument.Content.Find.Execute FindText:="^b", ReplaceWith:="", Replace:=wdReplaceAll '删除分节符
    ActiveDocument.Content.Find.Execute FindText:="^m", ReplaceWith:="", Replace:=wdReplaceAll '删除分页符
    
End Sub

Sub 删除分页符分节符4()
    Call 删除分页符4_1
    Call 删除分节符4_2
    MsgBox "已删除所有分页符分节符"
End Sub


Sub 遍历设置各级段落样式5()
'
'遍历每个段落 逐段落进行标题匹配设置样式
'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Selection.HomeKey Unit:=wdStory
    Dim t2_reg, t3_reg, t4_reg, t5_reg, t6_reg, t7_reg, cankao_reg
        
    Set t2_reg = CreateObject("vbscript.regexp")
    t2_reg.pattern = "^(第[一二三四五六七八九十 ]+篇[^\r]*)\r"
    Set t3_reg = CreateObject("vbscript.regexp")
    
    Dim para As Paragraph
    Dim isSearched As Boolean
    Dim pos As Long
    For Each para In ActiveDocument.Paragraphs
        '用if-elseif更好-不想改了
        isSearched = False
        If t2_reg.test(para.Range.text) And Not isSearched Then
            isSearched = True
            para.Style = ActiveDocument.Styles(wdStyleHeading2)
            pos = InStr(para.Range.text, "篇") + 1
            para.Range.Characters(pos).InsertBefore " " '此段落一定有篇
        End If
        
    Next
    Selection.HomeKey Unit:=wdStory
    MsgBox "遍历设置各级段落样式完成"

End Sub

Sub 设置各级标题样式5()
'不推荐-慢
'采用正则匹配，然后查找设置对应的段落格式
'https://devbox.cn/p/Zai_vba_Zhong_di_460e0cc1.html(非对象不使用set，需要提前Dim声明，对象需要set，可不Dim声明)
'可简化成1个函数，传参遍历执行-但不想！
'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim t2_reg, t3_reg, t4_reg, t5_reg, t6_reg, t7_reg, strA$  '最后1个$ 只对strA有效
    strA = ActiveDocument.Content.text
    Set t2_reg = CreateObject("vbscript.regexp")

    '二级标题
    Selection.HomeKey Unit:=wdStory
    t2_reg.pattern = "\r(第[一二三四五六七八九十 ]+篇[^\r]*)\r"
    t2_reg.Global = True
    Set t2_titles = t2_reg.Execute(strA)
    
    For Each t2_title In t2_titles
        With Selection.Find
            .ClearFormatting
            .text = t2_title.SubMatches(0)
            .Execute Forward:=True
        End With
    
        Selection.Style = ActiveDocument.Styles(wdStyleHeading2)
    
        Selection.HomeKey Unit:=wdStory
    Next
    MsgBox "标题正文样式设置完成"
End Sub


Sub 设置图表样式6()
'
'设置图表样式
'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim mytable As Table
    For Each mytable In ActiveDocument.Tables
        With mytable
            .TopPadding = PixelsToPoints(0, True)
            .BottomPadding = PixelsToPoints(0, True)
            .LeftPadding = PixelsToPoints(0, True)
            .RightPadding = PixelsToPoints(0, True)
            .Spacing = PixelsToPoints(0, True)
            .AllowPageBreaks = True
            .AllowAutoFit = True
            With .Rows
                .WrapAroundText = False
                .Alignment = wdAlignRowCenter
                .AllowBreakAcrossPages = False
                .HeightRule = wdRowHeightExactly
                .Height = CentimetersToPoints(0)
                .LeftIndent = CentimetersToPoints(0)
            End With
            
            With .Range
                With .Font
                    .Name = "宋体"
                    .Name = "Times New Roman"
                    .Color = wdColorAutomatic
                    .Size = 7.5
                    .Kerning = 0
                    .DisableCharacterSpaceGrid = True
                End With
                
                With .ParagraphFormat
                    .CharacterUnitFirstLineIndent = 0
                    .FirstLineIndent = CentimetersToPoints(0)
                    .LineSpacingRule = wdLineSpaceSingle
                    .Alignment = wdAlignParagraphCenter
                    .AutoAdjustRightIndent = False
                    .DisableLineHeightGrid = True
                    
                    .LeftIndent = CentimetersToPoints(0)
                    .RightIndent = CentimetersToPoints(0)
                    .FirstLineIndent = CentimetersToPoints(0)
                    .CharacterUnitLeftIndent = 0
                    .CharacterUnitRightIndent = 0
                    .CharacterUnitFirstLineIndent = 0
                End With
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            End With

            .PreferredWidthType = wdPreferredWidthPoints
            .PreferredWidth = CentimetersToPoints(14.5)
            With .Borders
                .InsideLineStyle = wdLineStyleSingle
                .OutsideLineStyle = wdLineStyleSingle
                .InsideLineWidth = wdLineWidth025pt
                .OutsideLineWidth = wdLineWidth025pt
                .InsideColor = wdColorAutomatic
                .OutsideColor = wdColorAutomatic
            End With
            
        End With
    Next
    Selection.HomeKey Unit:=wdStory

    Dim ishape As InlineShape
    For Each ishape In ActiveDocument.InlineShapes
        With ishape
            If .Type = wdInlineShapePicture Then
                .LockAspectRatio = msoTrue
                .Width = CentimetersToPoints(14.5)
            End If
        End With
        ishape.Range.Style = ActiveDocument.Styles("图片样式")

    Next
    Dim sh As Shape
    For Each sh In ActiveDocument.Shapes
        With sh
            If .Type = msoPicture Then
                .LockAspectRatio = msoTrue
                .Width = CentimetersToPoints(14.5)
            End If
        End With

        With Selection.ParagraphFormat
            .LeftIndent = CentimetersToPoints(0)
            .RightIndent = CentimetersToPoints(0)
            .FirstLineIndent = CentimetersToPoints(0)
        End With
    Next
    
    Selection.HomeKey Unit:=wdStory
    
    MsgBox "图表样式设置完成"

End Sub

Private Sub SetSuperscriptAndSubscript(ByVal PrefixChr As String, ByVal SetChr As String, Optional ByVal PostChr As String, Optional ByVal SuperscriptMode As Boolean = True)
   '程序功能：设置文档中特定字符为上标或下标。
   '参数说明：
   'PrefixChr：必选参数，要设置为上、下标字符之前的字符；
   'SetChr：必选参数，要设置为上、下标的字符；
   'PostChr:必选,但可赋空字符串,若为了界定整个替换符号而包含的后缀,防止误替换,可加此参数
   'SuperscriptMode：可选参数，设置为 True 表示将 SetChr 设置为上标，设置为 False 表示将 SetChr 设置为下标，默认为 True。

   Selection.Start = ActiveDocument.Paragraphs(1).Range.Start
   Selection.Collapse wdCollapseStart
   With Selection.Find
       .ClearFormatting
       .MatchCase = False
       .Replacement.ClearFormatting
       .text = PrefixChr & SetChr & PostChr
       .Replacement.text = .text
       If SuperscriptMode Then
           .Replacement.Font.Superscript = True
       Else
           .Replacement.Font.Subscript = True
       End If
       .Execute Replace:=wdReplaceAll
       .ClearFormatting
       .Replacement.ClearFormatting
       .text = PrefixChr
       If SuperscriptMode Then
           .Font.Superscript = True
       Else
           .Font.Subscript = True
       End If
       .Replacement.text = .text
       If SuperscriptMode Then
           .Replacement.Font.Superscript = False
       Else
           .Replacement.Font.Subscript = False
       End If
       .Execute Replace:=wdReplaceAll
       If Len(PostChr) > 0 Then
           .ClearFormatting
           .Replacement.ClearFormatting
           .text = PostChr
           If SuperscriptMode Then
               .Font.Superscript = True
           Else
               .Font.Subscript = True
           End If
           .Replacement.text = .text
           If SuperscriptMode Then
               .Replacement.Font.Superscript = False
           Else
               .Replacement.Font.Subscript = False
           End If
           .Execute Replace:=wdReplaceAll
       End If
   End With
End Sub


Sub 执行上下标7()
'
'依靠SetSuperscriptAndSubscript来实现
'
    Call SetSuperscriptAndSubscript("O", "+", "", True)
    Call SetSuperscriptAndSubscript("O", "-", "", True)
    
    Call SetSuperscriptAndSubscript("H", "2", "O", False)
    Call SetSuperscriptAndSubscript("TiO", "2", "", False)
    
    MsgBox "设置上下标完成"
End Sub

Sub 数字智能自动排版流程_遍历段落()
    MsgBox "这种遍历更快更好-磊磊"
    Call 设置标题正文模板样式1
    Call 设置页面参数2
    Call 删除空白行3
    Call 删除分页符分节符4
    Call 遍历设置各级段落样式5
    Call 设置图表样式6
    Call 执行上下标7
    MsgBox "已全部设置完成-磊磊"
End Sub