页面设置

乐乐2006201505

下面代码实现了设置各级别标题字体效果，但是一级标题段中有句号就会出错。还有把最后的句号删除。望哪位大师修改一下，同时实现其他要求。具体要求在第一个附件中，非常感谢！
ption Explicit
Sub 公文Text()
    Dim doc As Document, i As Paragraph
    Set doc = ActiveDocument

    Selection.WholeStory
    Selection.ClearFormatting
    CommandBars.FindControl(ID:=122).Execute
    CommandBars.FindControl(ID:=123).Execute
    删除空行
   
    Selection.WholeStory

    正文样式16

    Title2345

    For Each i In doc.Paragraphs
        With i.Range
            If .Style = "标题 2" Then
                .Font.Name = "黑体"
                .Font.Name = "Times New Roman"
            ElseIf .Style = "标题 3" Then
                .Font.Name = "楷体_GB2312"
                .Font.Name = "Times New Roman"
            ElseIf .Style = "标题 4" Then
                .Font.Name = "仿宋_GB2312"
                .Font.Name = "Times New Roman"
            ElseIf .Style = "标题 5" Then
                .Font.Name = "仿宋_GB2312"
                .Font.Name = "Times New Roman"
            ElseIf i.Range Like "[一二三四五六七八九十][，、 ]*" Or i.Range Like "[一二三四五六七八九十][是要]*" Then
                If Not i.Range Like "*。" & vbCr Then i.Range.Characters.Last.InsertBefore Text:="。"
                GoTo diyi
            End If
            If .Style <> "正文" Then
                If .Sentences.Count = 1 Then
                    If i.Range Like "*[。：；，、！？…—.:;,!?]" & vbCr Then i.Range.Characters.Last.Previous.Delete
                Else
diyi:
                    With .Font
                        .Name = "仿宋_GB2312"
                        .Name = "Times New Roman"
                        .Bold = False
'                        .Color = wdColorBlue
                    End With
                    With .Sentences(1).Font
                        .Bold = True
'                        .Color = wdColorBrown
                    End With
                End If
            End If
        End With
    Next
    特殊样式
End Sub

Sub 正文样式16()
    With Selection
        .ClearFormatting
        With .Font
            .Name = "仿宋_GB2312"
            .Name = "Times New Roman"
            .Size = 16
'            .Color = wdColorBlue
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
        With .ParagraphFormat
            .LineSpacing = LinesToPoints(1.25)
            .CharacterUnitFirstLineIndent = 2
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
        End With
    End With
End Sub

Sub Title2345()
    Dim mt, reg As Object, n&, m&, L&, ostr$, sr$, r1$, r2$, r3$, r4$
    ostr$ = Replace(ActiveDocument.Content, Chr(7), "")
    sr$ = "一二三四五六七八九十百零千〇"
    r1$ = "^[" & sr & "]+、": r2$ = "^[(（]\s*[" & sr & "]+\s*[)）]"
    r3$ = "^\d+[、.．]": r4$ = "^[(（]\s*\d+\s*[)）]"
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    reg.Pattern = "" & r2 & "|" & r1 & "|" & r4 & "|" & r3 & ""
    For Each mt In reg.Execute(ostr)
        m = mt.FirstIndex: n = mt.Length
        With ActiveDocument.Range(m, m + n)
            If Not .Information(wdWithInTable) Then
                .Expand 4: L = Len(.Text): .Collapse
                If .MoveWhile(sr, L) > 0 Then
                    .Expand 4
                    .Style = "标题 2"
'                    .Font.ColorIndex = 6
                ElseIf .MoveWhile("(（", L) > 0 Then
                    If .MoveWhile(sr, L) > 0 Then
                        .Expand 4
                        .Style = "标题 3"
'                        .Font.ColorIndex = 5
                    Else
                        .Expand 4
                        .Style = "标题 5"
'                        .Font.ColorIndex = 12
                    End If
                Else
                    .Expand 4
                    .Style = "标题 4"
'                    .Font.ColorIndex = 11
                End If
            End If
        End With
    Next
End Sub

Sub 删除空行()
    Dim i As Paragraph
    For Each i In ActiveDocument.Paragraphs
        If Len(i.Range) = 1 And Asc(i.Range) = 13 Then i.Range.Delete
    Next
End Sub

Sub 特殊样式()
    With Selection
        With .Font
            .Size = 16
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
        With .ParagraphFormat
            .SpaceBeforeAuto = False
            .SpaceAfterAuto = False
            .SpaceBefore = 0
            .SpaceAfter = 0
            .LineSpacing = LinesToPoints(1.25)
            .CharacterUnitFirstLineIndent = 2
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
            .KeepWithNext = False
            .KeepTogether = False
        End With
    End With
End Sub

乐乐2006201505

本代码大部分来自413191246se老师坛文《Word2003 通用模板宏（2018元旦版）》，非常感谢！[size=1em]如能看到此坛文，希望能够完善一下，就是各级标题行不止一个句子时，剩余句子[size=1em]全部变为正文字体，即仿宋_GB2312，或者标红。
Option Explicit
Sub 公文Text修改版main()
    Dim doc As Document, i As Paragraph
    Set doc = ActiveDocument
    Selection.WholeStory
    Selection.ClearFormatting
    CommandBars.FindControl(ID:=122).Execute
    CommandBars.FindControl(ID:=123).Execute
    删除空行
    Selection.WholeStory
    正文样式16
    Title2345
    For Each i In doc.Paragraphs
        With i.Range
            If .Style = "标题 2" Then
                .Font.Name = "黑体"
                .Font.Name = "Times New Roman"
            ElseIf .Style = "标题 3" Then
                .Font.Name = "楷体_GB2312"
                .Font.Name = "Times New Roman"
            ElseIf .Style = "标题 4" Then
                .Font.Name = "仿宋_GB2312"
                .Font.Name = "Times New Roman"
            ElseIf i.Range Like "[一二三四五六七八九十][，、 ]*" Or i.Range Like "[一二三四五六七八九十][是要]*" Then
                If Not i.Range Like "*。" & vbCr Then i.Range.Characters.Last.InsertBefore Text:="。"
                    With .Font
                        .Name = "黑体"
                        .Name = "Times New Roman"
                        .Bold = False
                    End With
            End If
            If .Style <> "正文" Then
                If .Sentences.Count = 1 Then
                    If i.Range Like "*[。：；，、！？…—.:;,!?]" & vbCr Then i.Range.Characters.Last.Previous.Delete
                End If
            End If

        End With
    Next
    特殊样式
    test
    test设置标题格式
End Sub

Sub 正文样式16()
    With Selection
        .ClearFormatting
        With .Font
            .Name = "仿宋_GB2312"
            .Name = "Times New Roman"
            .Size = 16
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
    End With
End Sub

Sub Title2345()
    Dim mt, reg As Object, n&, m&, L&, ostr$, sr$, r1$, r2$, r3$, r4$
    ostr$ = Replace(ActiveDocument.Content, Chr(7), "")
    sr$ = "一二三四五六七八九十百零千〇"
    r1$ = "^[" & sr & "]+、": r2$ = "^[(（]\s*[" & sr & "]+\s*[)）]"
    r3$ = "^\d+[、.．]": r4$ = "^[(（]\s*\d+\s*[)）]"
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    reg.Pattern = "" & r2 & "|" & r1 & "|" & r4 & "|" & r3 & ""
    For Each mt In reg.Execute(ostr)
        m = mt.FirstIndex: n = mt.Length
        With ActiveDocument.Range(m, m + n)
            If Not .Information(wdWithInTable) Then
                .Expand 4: L = Len(.Text): .Collapse
                If .MoveWhile(sr, L) > 0 Then
                    .Expand 4
                    .Style = "标题 2"
                ElseIf .MoveWhile("(（", L) > 0 Then
                    If .MoveWhile(sr, L) > 0 Then
                        .Expand 4
                        .Style = "标题 3"
                    End If
                Else
                    .Expand 4
                    .Style = "标题 4"
                End If
            End If
        End With
    Next
End Sub

Sub 删除空行()
    Dim i As Paragraph
    For Each i In ActiveDocument.Paragraphs
        If Len(i.Range) = 1 And Asc(i.Range) = 13 Then i.Range.Delete
    Next
End Sub

Sub 删除首页页眉横线()
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Sub 取消首页页码()
    Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight, FirstPage:=False
    删除首页页眉横线
End Sub

Sub 特殊样式()
    With Selection
        With .Font
            .Size = 16
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
        With .ParagraphFormat
            .SpaceBeforeAuto = False
            .SpaceAfterAuto = False
            .SpaceBefore = 0
            .SpaceAfter = 0
            .LineSpacingRule = wdLineSpaceExactly
            .LineSpacing = 28
            .Alignment = wdAlignParagraphLeft
            .CharacterUnitFirstLineIndent = 2
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
            .KeepWithNext = False
            .KeepTogether = False
        End With
    End With
End Sub

Sub test()
    Application.ScreenUpdating = False
    With ActiveDocument.Sections(1)
        .PageSetup.OddAndEvenPagesHeaderFooter = True
        With .Footers(wdHeaderFooterPrimary)
            With .PageNumbers
                .Add PageNumberAlignment:=wdAlignPageNumberRight
                .NumberStyle = wdPageNumberStyleNumberInDash
            End With
            With .Range.Frames(1)
                .HorizontalPosition = wdFrameRight
                '字体
                .Select
                Selection.Font.Name = "宋体"
                Selection.Font.Size = 12
                With .Range.ParagraphFormat
                    .Alignment = wdAlignParagraphRight
                    .CharacterUnitRightIndent = 1
                End With
            End With
        End With
        With .Footers(wdHeaderFooterEvenPages).Range.Frames(1)
            .HorizontalPosition = wdFrameLeft
            '字体
            .Select
            Selection.Font.Name = "宋体"
            Selection.Font.Size = 12
            With .Range.ParagraphFormat
                .Alignment = wdAlignParagraphLeft
                .CharacterUnitLeftIndent = 1
            End With
        End With
    End With
    '关闭页眉设置
    ActiveWindow.ActivePane.Close
    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
        ActiveWindow.ActivePane.View.Type = wdPrintView
    Else
        ActiveWindow.View.Type = wdPrintView
    End If
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Application.ScreenUpdating = True
End Sub

Sub test设置标题格式()
    Dim myDoc As Document, Content&
    Set myDoc = ActiveDocument
    Content = InputBox("请输入标题行有几行", "请输入", "1")
    myDoc.Range(myDoc.Paragraphs(1).Range.Start, myDoc.Paragraphs(Content).Range.End).Select
    Selection.ClearFormatting  '清除首行格式
    Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter  '设置首行居中对齐
    Selection.ParagraphFormat.LineUnitAfter = 1  '设置首行段后间距1行
    Selection.Font.Name = "方正小标宋简体"  '设置首行字体为“微软雅黑”
    Selection.Font.Size = 22  '设置首行字号为二号
    Selection.EndKey Unit:=wdLine  '移至首行末尾
End Sub

wdpfox

我认为标题末尾一般是不用句号的

413191246se

略。。。。。。。。。。。。

458863601

413191246se 发表于 2018-5-8 01:37
乐乐 你好！谢谢你试用我的代码，老师不敢当！我也只是会一点皮毛而已。我注意到你的下载附件是 2007  ...

怎样设置固定的页眉，修改正文的字号大小。