word vba自动化排版

2024-07-01 03:07| 来源: 网络整理| 查看: 265

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

【本文地址】

公司简介

联系我们