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.直接上代码

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

<code>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