word公文自动排版VBA代码，拿走不谢
Sub 文档初始化() '公文格式初始化
Selection.WholeStory '选择word 所有文档
Selection.ClearFormatting '文档格式清除
Selection.Range.HighlightColorIndex = wdNoHighlight '突出显示文本取消
With Selection.Paragraphs '段落设置
.Alignment = wdAlignParagraphLeft '左对齐
.LineSpacingRule = wdLineSpaceExactly '行距固定28.8
.LineSpacing = 28.8
.IndentFirstLineCharWidth 3 '首行缩进2个字符
End With
With Selection.Font '字体设置
.Name = "仿宋_GB2312" '字体名称
.Size = 16 '三号字体
.ColorIndex = wdBlack '黑色
End With
End Sub
Sub 标题正文设置()
With Selection.PageSetup '页面设置
.TopMargin = CentimetersToPoints(3.7) '顶端边距
.BottomMargin = CentimetersToPoints(3.5) '底端边距
.LeftMargin = CentimetersToPoints(2.8) '左边距
.RightMargin = CentimetersToPoints(2.6) '右边距
'.PageWidth = CentimetersToPoints(18.2) '页面宽度
'.PageHeight = CentimetersToPoints(25.7) '页面高度
End With
'字体设置
Dim title_reg, f_reg, s_reg, th_reg, fr_reg, k, mh, strA$
Set myRange = ActiveDocument.Content
' 正则表达式 获取文档内容
strA = myRange.Text
Set title_reg = CreateObject("vbscript.regexp")
Set f_reg = CreateObject("vbscript.regexp")
Set s_reg = CreateObject("vbscript.regexp")
Set th_reg = CreateObject("vbscript.regexp")
Selection.HomeKey unit:=wdStory '光标回到文章开头
t = 0
title_reg.Pattern = "\r\r"
'[^\r]除了换行符之外的所有字符
title_reg.Global = True
Set Title = title_reg.Execute(strA)
With Selection.Find
.ClearFormatting
.Text = Title.Item(0)
.Execute Forward:=True
Selection.HomeKey unit:=wdStory, Extend:=wdExtend
End With
'选择有两个换行符的至开头的所有段落
With Selection.Font
.Name = "方正小标宋简体"
.Size = 22
.ColorIndex = wdBlack
End With
With Selection.Paragraphs '设置行距
.FirstLineIndent = CentimetersToPoints(0) '取消首行缩进
.Alignment = wdAlignParagraphCenter '段落居中
.LineSpacingRule = wdLineSpaceExactly '行距固定
.LineSpacing =
Word.Application.LinesToPoints(2.3) '行距为2.3倍行距 一行距=12
End With
' 以下是设置一级标题
t1 = 0 '初始化t1，作为一级标题是否是一是二是三是的标记，如果是，则为1，不是则为0
Selection.HomeKey unit:=wdStory
f_reg.Pattern = "(一、|二、|三、|四、|五、|六、|七、|八、|九、|十、|十一、|十二、|十三、|十四、|十五、|十六、|十七、|十八、|十九、|二十、|二十一、|二十二、|二十三、|二十四、|二十五、|二十五、|二十五、|二十六、|二十七、|二十八、|二十九、|三十、)[^\r]*\r"
f_reg.Global = True
Set f_titles = f_reg.Execute(strA)
If f_titles.Count = 0 Then '如果一级标题是一是二是三是，则匹配
f_reg.Pattern = "(一是|二是|三是|四是|五是|六是|七是|八是|九是|十是|十一是|十二是|十三是|十四是|十五是|十六是|十七是|十八是|十九是|二十是|二十一是|二十二是|二十三是|二十四是|二十五是|二十六是|二十七是|二十八是|二十九是|三十是)([^。])*。"
Set f_titles = f_reg.Execute(strA)
t1 = 1
End If
For Each f_title In f_titles
With Selection.Find
.ClearFormatting
.Text = f_title.Value
Debug.Print "一级标题遍历项目："; f_title.Value
.Execute Forward:=True
End With
With Selection.Font
.Name = "黑体"
.Size = "16"
.ColorIndex = wdBlack
End With
Selection.HomeKey unit:=wdStory
Next
' 以下是设置二级标题
If t1 = 0 Then 'p判断一级标题是否是一是二是三是的标记，如果是0，则不是一是二是三是，则执行，不是则不执行
t2 = 0
Selection.HomeKey unit:=wdStory
s_reg.Global = True
s_reg.Pattern = "(（一）|（二）|（三）|（四）|（五）|（六）|（七）|（八）|（九）|（十）|（十一）|（十二）|（十三）|（十四）|（十五）|（十六）|（十七）|（十八）|（十九）|（二十）|（二十一）|（二十二）|（二十三）|（二十四）|（二十五）|（二十六）|（二十七）|（二十八）|（二十九）|（三十）)([^。\r：])*[。|\r：]" '排除句号和段落符号查找所有，找到句号或段落符号后停止
Set s_titles = s_reg.Execute(strA)
If s_titles.Count = 0 Then '如果二级标题是一是二是三是，则匹配
s_reg.Pattern = "(一是|二是|三是|四是|五是|六是|七是|八是|九是|十是|十一是|十二是|十三是|十四是|十五是|十六是|十七是|十八是|十九是|二十是|二十一是|二十二是|二十三是|二十四是|二十五是|二十六是|二十七是|二十八是|二十九是|三十是)([^。])*。"
Set s_titles = s_reg.Execute(strA)
t2 = 1
End If
For Each s_title In s_titles
With Selection.Find
.ClearFormatting
.Text = s_title.Value
Debug.Print "二级标题遍历项目："; s_title.Value
.Execute Forward:=True
End With
With Selection.Font
.Name = "楷体"
.Size = "16"
.ColorIndex = wdBlack
.Bold = True
End With
Selection.HomeKey unit:=wdStory
Next
End If
' 以下是设置三级标题
If t2 = 0 Then
Selection.HomeKey unit:=wdStory
th_reg.Global = True
th_reg.Pattern = "\r\d{1,2}\.([^。])*。"
Set th_titles = th_reg.Execute(strA)
If th_titles.Count = 0 Then '如果三级标题是一是二是三是，则匹配
th_reg.Pattern = "(一是|二是|三是|四是|五是|六是|七是|八是|九是|十是|十一是|十二是|十三是|十四是|十五是|十六是|十七是|十八是|十九是|二十是|二十一是|二十二是|二十三是|二十四是|二十五是|二十六是|二十七是|二十八是|二十九是|三十是)([^。])*。"
Set th_titles = th_reg.Execute(strA)
End If
For Each th_title In th_titles
With Selection.Find
.ClearFormatting
.Text = th_title.Value
Debug.Print "三级标题遍历项目："; th_title.Value
.Execute Forward:=True
End With
With Selection.Font
.Bold = True
.ColorIndex = wdBlack
End With
Selection.HomeKey unit:=wdStory
Next
End If
End Sub
Sub 页码设置()
ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True
With ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary) '进入页脚编辑状态
.Range.Font.Size = 15
.Range.Font.Name = "仿宋"
.Range.Collapse Direction:=wdCollapseEnd
End With
End Sub
Sub 删除页眉横线()
With ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range '进入页脚编辑状态
.Delete '删除页眉中的内容
.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone '段落下边框线
End With
End Sub
Sub 公文格式排版()
Call 文档初始化
Call 标题正文设置
Call 页码设置
Call 删除页眉横线
End Sub
