Word通过宏统一设置表格样式、图片样式、标题和正文样式、更新目录。
Sub A表格格式化_增强版()On Error Resume NextApplication.ScreenUpdating = FalseDim tbl As tableDim counter As Integer: counter = 1Dim response As VbMsgBoxResultFor Each tbl In ActiveDocument.TablesCall FormatSingleTable(tbl)' 进度提示If counter Mod 20 = 0 Thenresponse = MsgBox("已处理第 " & counter & " 个表格", vbOKCancel + vbInformation, "进度")If response = vbCancel Then Exit ForEnd Ifcounter = counter + 1Next tblApplication.ScreenUpdating = TrueIf response <> vbCancel ThenMsgBox "完成！共处理 " & (counter - 1) & " 个表格", vbInformationEnd If
End Sub' 单独处理每个表格的函数
Sub FormatSingleTable(tbl As table)On Error Resume Next' 表格基本设置With tbl.PreferredWidthType = wdPreferredWidthPercent.PreferredWidth = 100.AllowAutoFit = False.Rows.Alignment = wdAlignRowCenterEnd With' 边框设置With tbl.Borders.Enable = True.OutsideLineStyle = wdLineStyleSingle.OutsideLineWidth = wdLineWidth050pt.InsideLineStyle = wdLineStyleSingle.InsideLineWidth = wdLineWidth050ptEnd With' 逐个单元格处理（支持合并单元格）Dim r As Long, c As LongFor r = 1 To tbl.Rows.CountFor c = 1 To tbl.Columns.Count' 只处理每个合并区域的第一个单元格If Not IsMergedCell(tbl, r, c) ThenFormatTableCell tbl, r, cEnd IfNext cNext r
End Sub' 判断是否为合并单元格的重复部分
Function IsMergedCell(tbl As table, row As Long, col As Long) As BooleanOn Error Resume NextIsMergedCell = (tbl.cell(row, col).rowIndex <> row Or tbl.cell(row, col).ColumnIndex <> col)
End Function' 格式化单个单元格
Sub FormatTableCell(tbl As table, row As Long, col As Long)On Error Resume NextWith tbl.cell(row, col).VerticalAlignment = wdCellAlignVerticalCenter.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter.Range.Font.Name = "宋体".Range.Font.NameFarEast = "宋体".Range.Font.Size = 10.5.Range.Font.Color = RGB(0, 0, 0)If row = 1 Then.Range.Font.Bold = True.Shading.BackgroundPatternColor = RGB(242, 242, 242)Else.Range.Font.Bold = False.Shading.BackgroundPatternColor = wdColorAutomaticEnd IfEnd With
End Sub'' 厘米转磅函数（1厘米=28.35磅）
Function CentimetersToPoints(ByVal cm As Single) As SingleCentimetersToPoints = cm * 28.35
End FunctionSub B图片格式化()' 声明变量Dim shp As ShapeDim ilshp As InlineShapeDim pageWidth As SingleDim leftMargin As SingleDim rightMargin As SingleDim usableWidth As Single' 关闭屏幕更新以提高宏运行速度Application.ScreenUpdating = False' 设置错误处理，跳过无法处理的图片On Error Resume Next' 计算页面可用宽度（点数）With ActiveDocument.PageSetuppageWidth = .pageWidthleftMargin = .leftMarginrightMargin = .rightMarginEnd With' 计算可用宽度 = 页面宽度 - 左边距 - 右边距usableWidth = pageWidth - leftMargin - rightMargin' 第一部分：处理嵌入型图片（InlineShapes）For Each ilshp In ActiveDocument.InlineShapesIf ilshp.Type = wdInlineShapePicture Or ilshp.Type = wdInlineShapeLinkedPicture Then' 设置图片宽度为页面可用宽度ilshp.Width = usableWidth' ★ 新增：取消首行缩进并设置居中对齐With ilshp.Range.ParagraphFormat.CharacterUnitFirstLineIndent = 0 ' 取消字符单位首行缩进.FirstLineIndent = 0 ' 取消磅单位首行缩进.Alignment = wdAlignParagraphCenter ' 段落后中包括图片End WithEnd IfNext ilshp' 第二部分：处理浮动型图片（Shapes）For Each shp In ActiveDocument.ShapesIf shp.Type = msoPicture Or shp.Type = msoLinkedPicture Then' 锁定纵横比，设置宽度为页面可用宽度shp.LockAspectRatio = msoTrueshp.Width = usableWidth' ★ 新增：通过锚定段落取消首行缩进并居中对齐If Not shp.Anchor Is Nothing ThenWith shp.Anchor.ParagraphFormat.CharacterUnitFirstLineIndent = 0.FirstLineIndent = 0.Alignment = wdAlignParagraphCenterEnd WithEnd IfEnd IfNext shp' 完成提示（更新提示文本）MsgBox "图片设置已完成！" & vbCrLf & vbCrLf & _"所有图片已设置为页面宽度、居中对齐，并取消首行缩进。", _vbInformation, "图片样式设置"' 重新开启屏幕更新Application.ScreenUpdating = True
End SubSub C设置正文样式()' 关闭屏幕更新和响应提示以提高宏运行速度Application.ScreenUpdating = FalseApplication.DisplayAlerts = wdAlertsNoneDim para As Paragraph' 遍历文档中的所有段落For Each para In ActiveDocument.Paragraphs' 判断段落样式并应用相应格式Select Case para.styleCase "正文"With para.Range.Font.Name = "宋体".Size = 12 ' 小四号对应12磅.Color = RGB(0, 0, 0) ' 黑色.Bold = False.Italic = FalseEnd With' ★ 新增：检查段落是否包含图片或表格，不进行缩进If para.Range.InlineShapes.Count = 0 And para.Range.Tables.Count = 0 ThenWith para.Range.ParagraphFormat.LineSpacingRule = wdLineSpace1pt5 ' 1.5倍行距.SpaceBefore = 0.SpaceAfter = 0.CharacterUnitFirstLineIndent = 2 ' 首行缩进2个字符End WithElse' 对于包含图片或表格的段落，只设置基本段落格式，不缩进With para.Range.ParagraphFormat.LineSpacingRule = wdLineSpace1pt5.SpaceBefore = 0.SpaceAfter = 0.CharacterUnitFirstLineIndent = 0 ' 取消缩进.FirstLineIndent = 0 ' 取消磅单位缩进End With' 设置表格的字体为五号With para.Range.Font.Name = "宋体".Size = 10.5 ' 五号对应10.5磅.Color = RGB(0, 0, 0) ' 黑色.Bold = False.Italic = FalseEnd WithEnd IfEnd SelectNext para' 恢复屏幕更新和提示Application.ScreenUpdating = TrueApplication.DisplayAlerts = wdAlertsAll' 弹窗显示设置结果MsgBox "正文设置已完成！" & vbCrLf & vbCrLf & _"正文: 宋体，小四(12磅)，1.5倍行距" & vbCrLf & _" 普通段落：首行缩进2字符" & vbCrLf & _" 图片/表格段落：无缩进", _vbInformation, "正文样式设置"
End SubSub D清除现有列表样式()' 清除选定区域或全文的现有列表格式If Selection.Range.Start = Selection.Range.End Then' 如果未选中任何内容，则处理整个文档ActiveDocument.Range.ListFormat.RemoveNumbersElse' 如果已选中内容，则处理选中部分Selection.Range.ListFormat.RemoveNumbersEnd If' 弹窗显示设置结果MsgBox "样式已清除！", _vbInformation, "清除样式设置"End SubSub F带中文编号的多级列表()Dim listTemplate As listTemplateSet listTemplate = ActiveDocument.ListTemplates.Add(OutlineNumbered:=True)With listTemplate' 第1级：第一章With .ListLevels(1).NumberFormat = "第%1章" ' 设置编号格式为"第1章"等形式，%1代表第一级数字.NumberStyle = wdListNumberStyleArabic ' 设置编号样式为阿拉伯数字.LinkedStyle = "标题 1" ' 将此列表级别链接到"标题 1"样式.NumberPosition = 0 ' 设置编号的悬挂缩进位置（单位为磅）.TextPosition = 54 ' 设置文本的缩进位置（单位为磅）.StartAt = 1 ' 设置起始编号为1.TrailingCharacter = wdTrailingSpace ' 设置编号后的尾随字符为空格（与文本分隔）End With' 第2级：1.1With .ListLevels(2).NumberFormat = "%1.%2".NumberStyle = wdListNumberStyleArabic.LinkedStyle = "标题 2".NumberPosition = 54.TextPosition = 90.StartAt = 1.TrailingCharacter = wdTrailingSpace.ResetOnHigher = 1End With' 第3级：1.1.1With .ListLevels(3).NumberFormat = "%1.%2.%3".NumberStyle = wdListNumberStyleArabic.LinkedStyle = "标题 3".NumberPosition = 90.TextPosition = 126.StartAt = 1.TrailingCharacter = wdTrailingSpace.ResetOnHigher = 2End With' 第4级：1.1.1.1With .ListLevels(4).NumberFormat = "%1.%2.%3.%4".NumberStyle = wdListNumberStyleArabic.LinkedStyle = "标题 4".NumberPosition = 126.TextPosition = 162.StartAt = 1.TrailingCharacter = wdTrailingSpace.ResetOnHigher = 3End With' 第5级: 1.1.1.1.1With .ListLevels(5).NumberFormat = "%1.%2.%3.%4.%5".NumberStyle = wdListNumberStyleArabic.LinkedStyle = "标题 5".NumberPosition = 162.TextPosition = 198.StartAt = 1.TrailingCharacter = wdTrailingSpace.ResetOnHigher = 4End With' 第6级：(1)With .ListLevels(6).NumberFormat = "(%6)".NumberStyle = wdListNumberStyleArabic.LinkedStyle = "标题 6".NumberPosition = 198.TextPosition = 234.StartAt = 1.TrailingCharacter = wdTrailingSpace.ResetOnHigher = 5End WithEnd With' 设置标题样式的字体格式SetHeadingStylesFormat' 遍历所有段落，应用标题样式For Each para In ActiveDocument.ParagraphsIf para.style Like "标题 *" ThenDim level As Integerlevel = Val(Right(para.style, 1))' 保存原始对齐方式originalAlignment = para.Range.ParagraphFormat.AlignmentIf level >= 1 And level <= 6 Then' 应用对应的中文标题样式para.style = ActiveDocument.Styles("标题 " & level)End If' 恢复原始对齐方式para.Range.ParagraphFormat.Alignment = originalAlignmentEnd IfNext paraMsgBox "标题样式设置完成！", vbInformation, "标题样式设置"End Sub' 设置标题样式的字体格式
Function SetHeadingStylesFormat()On Error Resume Next' 标题1样式设置：第一章With ActiveDocument.Styles("标题 1").Font.Name = "黑体" ' 字体.Size = 22 ' 字号 二号.Bold = True ' 加粗.Color = RGB(0, 0, 0) ' 黑色.Italic = False ' 非斜体.Underline = wdUnderlineNone ' 无下划线End WithWith ActiveDocument.Styles("标题 1").ParagraphFormat.Alignment = wdAlignParagraphLeft ' 左对齐.LineSpacingRule = wdLineSpaceSingle ' 单倍行距.SpaceBefore = 12 ' 段前间距.SpaceAfter = 6 ' 段后间距' 关键：设置所有缩进为0.LeftIndent = 0.RightIndent = 0.FirstLineIndent = 0.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0End With' 标题2样式设置：1.1With ActiveDocument.Styles("标题 2").Font.Name = "黑体".Size = 16 ' 字体 三号.Bold = True.Color = RGB(0, 0, 0) ' 黑色.Italic = FalseEnd WithWith ActiveDocument.Styles("标题 2").ParagraphFormat.Alignment = wdAlignParagraphLeft ' 左对齐.LineSpacingRule = wdLineSpaceSingle.SpaceBefore = 12.SpaceAfter = 6.FirstLineIndent = 0 ' 首行不缩进' 关键：设置所有缩进为0.LeftIndent = 0.RightIndent = 0.FirstLineIndent = 0.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0End With' 标题3样式设置：1.1.1With ActiveDocument.Styles("标题 3").Font.Name = "宋体".Size = 14 ' 字体 四号.Bold = True.Color = RGB(0, 0, 0).Italic = FalseEnd WithWith ActiveDocument.Styles("标题 3").ParagraphFormat.Alignment = wdAlignParagraphLeft.LineSpacingRule = wdLineSpaceSingle.SpaceBefore = 6.SpaceAfter = 3.FirstLineIndent = 0' 关键：设置所有缩进为0.LeftIndent = 0.RightIndent = 0.FirstLineIndent = 0.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0End With' 标题4样式设置：1.1.1.1With ActiveDocument.Styles("标题 4").Font.Name = "宋体".Size = 12 '字体 小四.Bold = True.Color = RGB(0, 0, 0).Italic = FalseEnd WithWith ActiveDocument.Styles("标题 4").ParagraphFormat.Alignment = wdAlignParagraphLeft.LineSpacingRule = wdLineSpaceSingle.SpaceBefore = 6.SpaceAfter = 3.FirstLineIndent = 0' 关键：设置所有缩进为0.LeftIndent = 0.RightIndent = 0.FirstLineIndent = 0.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0End With' 标题5样式设置：1.1.1.1.1With ActiveDocument.Styles("标题 5").Font.Name = "宋体".Size = 12 ' 字体 小四.Bold = False ' 不加粗.Color = RGB(0, 0, 0).Italic = FalseEnd WithWith ActiveDocument.Styles("标题 5").ParagraphFormat.Alignment = wdAlignParagraphLeft.LineSpacingRule = wdLineSpaceSingle.SpaceBefore = 3.SpaceAfter = 3.FirstLineIndent = 0' 关键：设置所有缩进为0.LeftIndent = 0.RightIndent = 0.FirstLineIndent = 0.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0End With' 标题6样式设置：(1)With ActiveDocument.Styles("标题 6").Font.Name = "宋体".Size = 12.Bold = False.Color = RGB(0, 0, 0).Italic = FalseEnd WithWith ActiveDocument.Styles("标题 6").ParagraphFormat.Alignment = wdAlignParagraphLeft.LineSpacingRule = wdLineSpaceSingle.SpaceBefore = 3.SpaceAfter = 3.FirstLineIndent = 0' 关键：设置所有缩进为0.LeftIndent = 0.RightIndent = 0.FirstLineIndent = 0.CharacterUnitLeftIndent = 0.CharacterUnitRightIndent = 0.CharacterUnitFirstLineIndent = 0End WithOn Error GoTo 0
End Function' 创建目录样式，并刷新目录
Sub G刷新目录()On Error Resume NextApplication.ScreenUpdating = FalseDim originalRange As RangeSet originalRange = Selection.Range' 检查是否存在目录If ActiveDocument.TablesOfContents.Count = 0 ThenIf MsgBox("文档中没有找到目录，是否创建目录？", vbYesNo + vbQuestion, "创建目录") = vbYes ThenCreateTOCElseApplication.ScreenUpdating = TrueExit SubEnd IfEnd If' 设置目录样式SetAllTOCStyles' 刷新目录UpdateAllTOC' 返回原位置originalRange.SelectApplication.ScreenUpdating = TrueMsgBox "目录样式设置完成！" & vbCrLf & _"字体：宋体" & vbCrLf & _"字号：小四（12磅）", vbInformation, "目录格式设置"
End Sub' 创建目录（在第2页）
Function CreateTOC()' 移动到文档开头Selection.HomeKey Unit:=wdStory' 如果文档页数不足2页，则插入分页符直到有第2页If ActiveDocument.ComputeStatistics(wdStatisticPages) < 2 ThenSelection.InsertBreak Type:=wdPageBreakEnd If' 移动到第1页开头MoveToPage 1' 插入分页符，确保目录从新页面开始（如果需要）If Selection.Information(wdActiveEndPageNumber) <> 2 ThenSelection.InsertBreak Type:=wdPageBreakMoveToPage 2End If' 添加"目录"标题Selection.style = ActiveDocument.Styles("标题 1")Selection.TypeText text:="目录"Selection.TypeParagraph' 插入目录字段ActiveDocument.TablesOfContents.Add _Range:=Selection.Range, _RightAlignPageNumbers:=True, _UseHeadingStyles:=True, _UpperHeadingLevel:=1, _LowerHeadingLevel:=3, _IncludePageNumbers:=True, _UseHyperlinks:=True, _AddedStyles:="", _UseFields:=True, _TableID:=""' 在目录后添加分页符，确保后续内容从新页面开始Selection.InsertBreak Type:=wdPageBreakEnd Function' 跳转到指定页码
Function MoveToPage(pageNumber As Integer)On Error Resume NextSelection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=pageNumber
End Function' 设置所有目录样式
Function SetAllTOCStyles()Dim i As IntegerDim style As style' 设置1-9级目录样式For i = 1 To 9SetTOCStyleWithLevel "目录 " & i, "宋体", 12SetTOCStyleWithLevel "TOC " & i, "宋体", 12Next i
End Function' 设置带级别的目录样式
Function SetTOCStyleWithLevel(styleName As String, fontName As String, fontSize As Single)On Error Resume NextDim style As styleSet style = ActiveDocument.Styles(styleName)If Not style Is Nothing ThenWith style.Font.Name = fontName.NameFarEast = fontName.Size = fontSizeEnd With' 设置缩进（根据级别）With style.ParagraphFormat.LeftIndent = CentimetersToPoints(0).FirstLineIndent = CentimetersToPoints(0).LineSpacingRule = wdLineSpaceSingle.SpaceAfter = 3End WithEnd If
End Function' 刷新所有目录
Function UpdateAllTOC()Dim toc As TableOfContentsDim table As TableOfFigures' 刷新正文目录For Each toc In ActiveDocument.TablesOfContentstoc.UpdateNext toc' 刷新图表目录For Each table In ActiveDocument.TablesOfFigurestable.UpdateNext table
End FunctionSub H调整文档中标题等级()Dim para As ParagraphDim currentStyle As styleDim highestLevel As IntegerDim levelOffset As IntegerDim i As Integer' 初始化最高级别为最大值highestLevel = 9' 第一步：扫描文档，找出最低的标题级别（数字最小的）For Each para In ActiveDocument.ParagraphsIf para.style Like "标题 *" Then' 提取标题级别数字i = Val(Right(para.style, 1))If i < highestLevel ThenhighestLevel = iEnd IfEnd IfNext para' 如果没有找到任何标题，退出宏If highestLevel = 9 ThenMsgBox "文档中没有找到标题样式。"Exit SubEnd If' 第二步：如果最高级别已经是1，无需调整If highestLevel = 1 ThenMsgBox "文档中已包含级别1标题，无需调整。"Exit SubEnd If' 计算需要升级的级数levelOffset = highestLevel - 1' 第三步：遍历所有段落，调整标题级别For Each para In ActiveDocument.ParagraphsIf para.style Like "标题 *" Then' 保存原始对齐方式originalAlignment = para.Range.ParagraphFormat.Alignment' 提取当前标题级别i = Val(Right(para.style, 1))' 计算新的标题级别Dim newLevel As IntegernewLevel = i - levelOffset' 确保新级别在有效范围内（1-9）If newLevel >= 1 And newLevel <= 9 Then' 应用新的标题样式para.style = "标题 " & newLevelElseIf newLevel < 1 Then' 如果计算出的级别小于1，强制设为1para.style = "标题 1"End If' 恢复原始对齐方式para.Range.ParagraphFormat.Alignment = originalAlignmentEnd IfNext paraMsgBox "标题级别调整完成！原最高级别" & highestLevel & "已调整为级别1。"
End SubSub D清除现有列表样式_非标准编号()Dim para As ParagraphDim rng As RangeDim counter As IntegerDim originalText As StringDim newText As Stringcounter = 0Application.ScreenUpdating = FalseFor Each para In ActiveDocument.ParagraphsIf para.style Like "标题 *" ThenSet rng = para.RangeoriginalText = rng.text' 去除段落结束标记（通常是回车符）originalText = Left(originalText, Len(originalText) - 1)' 检查是否有编号模式If HasNumberPattern(originalText) ThennewText = RemoveNumberPatterns(originalText)' 只有当文本确实发生变化时才更新If newText <> originalText Then' 重要：只替换文本内容，保持段落结构完整rng.MoveEnd wdCharacter, -1 ' 排除段落标记rng.text = newTextcounter = counter + 1' 重新应用标题样式Dim level As Integerlevel = GetHeadingLevel(para.style)If level > 0 Thenrng.style = "标题 " & levelEnd IfEnd IfEnd If' 清除列表格式（安全操作）On Error Resume Nextpara.Range.ListFormat.RemoveNumbersOn Error GoTo 0End IfNext paraApplication.ScreenUpdating = TrueMsgBox "已快速清理 " & counter & " 个标题的非标准编号。"
End SubFunction RemoveNumberPatterns(text As String) As StringDim result As Stringresult = text' 去除各种常见的编号模式' 1. 数字+点+空格 (如 "1. ", "1.1. ", "1.1.1. ")' 2. 数字+空格 (如 "1 ", "1.1 "，"1.1.1 ")result = RegExReplace(result, "^\d+\.\d+\.\d+\.\d+\.\d+\.\s?", "")result = RegExReplace(result, "^\d+\.\d+\.\d+\.\d+\.\d+\s?", "")result = RegExReplace(result, "^\d+\.\d+\.\d+\.\d+\.\s?", "")result = RegExReplace(result, "^\d+\.\d+\.\d+\.\d+\s?", "")result = RegExReplace(result, "^\d+\.\d+\.\d+\.\s?", "")result = RegExReplace(result, "^\d+\.\d+\.\d+\s?", "")result = RegExReplace(result, "^\d+\.\d+\.\s?", "")result = RegExReplace(result, "^\d+\.\d+\s?", "")result = RegExReplace(result, "^\d+\.\s?", "")result = RegExReplace(result, "^\d+\s?", "")' 3. 中文数字+顿号 (如 "一、", "二、")result = RegExReplace(result, "^[一二三四五六七八九十]、", "")' 4. 字母+点+空格 (如 "A. ", "a. ")result = RegExReplace(result, "^[A-Za-z]\.\s?", "")' 5. 罗马数字+点+空格 (如 "I. ", "II. ")result = RegExReplace(result, "^[IVXLCDM]+\.\s?", "")' 6. 带括号的数字 (如 "(1)", "(1.1)")result = RegExReplace(result, "^\(\d+\)\s?", "")result = RegExReplace(result, "^\(\d+\.\d+\)\s?", "")' 7. 去除开头空格result = Trim(result)RemoveNumberPatterns = result
End Function' 正则表达式替换函数
Function RegExReplace(text As String, pattern As String, replacement As String) As StringDim regEx As ObjectSet regEx = CreateObject("VBScript.RegExp")With regEx.Global = True.IgnoreCase = True.MultiLine = False.pattern = patternEnd WithIf regEx.Test(text) ThenRegExReplace = regEx.Replace(text, replacement)ElseRegExReplace = textEnd If
End FunctionFunction HasNumberPattern(text As String) As Boolean' 检测文本是否包含常见的编号模式Dim patterns(10) As StringDim i As Integerpatterns(0) = "^\d+\." ' 数字+点patterns(1) = "^\d+" ' 数字patterns(2) = "^[一二三四五六七八九十]、" ' 中文数字patterns(3) = "^[A-Za-z]\." ' 字母+点patterns(4) = "^[IVXLCDM]+\." ' 罗马数字patterns(5) = "^\(\d+\)" ' 括号数字For i = 0 To 5If RegExTest(text, patterns(i)) ThenHasNumberPattern = TrueExit FunctionEnd IfNext iHasNumberPattern = False
End FunctionFunction RegExTest(text As String, pattern As String) As BooleanDim regEx As ObjectSet regEx = CreateObject("VBScript.RegExp")With regEx.Global = False.IgnoreCase = True.pattern = patternEnd WithRegExTest = regEx.Test(text)
End FunctionFunction GetHeadingLevel(styleName As String) As IntegerIf styleName Like "标题 *" ThenGetHeadingLevel = Val(Right(styleName, 1))ElseGetHeadingLevel = 0End If
End Function
