word vba自动化排版-设置标题模板样式、标题、正文、图表、页面、上下标等设置、删除空白行、删除分页符分节符、删除空格等
目录
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.直接上代码
涉及：设置标题图片模板样式、标题、正文、图表、页面、上下标等样式、删除空白行、删除分页符分节符、删除空格等
vbnet
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