Word2003VBA 通用模板宏(2019元旦版)更新:2018-12-29

'http://club.excelhome.net/thread-1452376-1-1.html

Attribute VB_Name = "NewMacros"
Option Explicit
Sub AutoOpen()
    On Error Resume Next
    Dim y$, x$, s As Section, i&, j&
    With ActiveDocument
        y = .FullName
        If y Like "*.docx" Then
            If MsgBox("是否转换为 Word2003 格式?", vbYesNo + vbCritical) = vbYes Then
                x = Left(y, Len(y) - 5)
                .SaveAs FileName:=x, FileFormat:=wdFormatDocument
                If MsgBox("是否删除源文件?", 4 + 16) = vbYes Then
                    .Close
                    Kill y
                    Documents.Open FileName:=x
                End If
            End If
        End If
        For Each s In .Sections
            With s.PageSetup
                If .Orientation = wdOrientLandscape Then j = 1
                If .PaperSize <> wdPaperA4 Then
                    If i = 0 Then i = 1: If MsgBox("是否改为A4纸张?", 4 + 16) = vbNo Then Exit Sub
                    .PaperSize = wdPaperA4
                    If j = 1 Then .Orientation = wdOrientLandscape
                End If
            End With
            j = 0
        Next
        If .Tables.Count > 0 Then CommandBars("Tables and Borders").Visible = True Else CommandBars("Tables and Borders").Visible = False
    End With
End Sub
Sub AutoClose()
    ActiveWindow.DocumentMap = False
End Sub
Sub 公文()
    Dim t!, x&, y&, s!
    x = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
    t = Timer
    核心
    s = Round(Timer - t, 2)
    y = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
    显示页数
    ActiveWindow.DocumentMapPercentWidth = 20
    MsgBox "排版完毕! 用时 " & s & " 秒! 共 " & Selection.Information(wdNumberOfPagesInDocument) & " 页!     " & vbCr & vbCr & "排版前字数 = " & x & vbCr & "排版后字数 = " & y, 0 + 48
    ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
End Sub
Sub 核心()
    Dim doc As Document, t As Table, j As Long, k As Long, i As Long
    Set doc = ActiveDocument
    ActiveWindow.View.Type = wdPrintView
    PaperSetup

    With doc
        With .Content.Find
            .Execute "^13", , , , , , , , , "^p", 2
            .Execute "^11", , , , , , , , , "^p", 2
            .Parent.ListFormat.ConvertNumbersToText
        End With

        With .Paragraphs.Last.Range
            If .Text Like "*" & vbTab & vbCr Then .Delete
        End With

        If .Tables.Count = 0 Then
            .Select
            正文样式
        Else
            '取消环绕
            For Each t In .Tables
                With t.Range.Rows
                    .WrapAroundText = False
                    .Alignment = wdAlignRowCenter
                End With
            Next

            '首表上方
            If .Paragraphs(1).Range.Information(wdWithInTable) = False Then
                .Range(Start:=0, End:=.Tables(1).Range.Start).Select
                正文样式
            End If

            '表间循环
            k = .Tables.Count
rc:
            For j = 1 To k
                If j = k Then Exit For
                .Range(Start:=.Tables(j).Range.End, End:=.Tables(j + 1).Range.Start).Select
                正文样式
                i = k
                k = .Tables.Count
                If k = i - 1 Then GoTo rc
            Next j

            '末表下方
            .Range(Start:=.Tables(k).Range.End, End:=.Content.End).Select
            正文样式

            '表下加空
            For Each t In .Tables
                With t.Range.Next
                    If Asc(.Text) <> 13 Then .InsertParagraphBefore: .MoveEnd 1, -1
                    .Font.Size = 4
                End With
            Next
        End If

        With .Content.Find
            .Execute "(", , , , , , , , , "(", 2
            .Execute ")", , , , , , , , , ")", 2
            .Execute ")、", , , , , , , , , ")", 2

            .Execute "([、..])([  ^s^t]{1,})", , , 1, , , , , , "\1", 2
            .Execute "([  ^s^t]@)([、..])", , , 1, , , , , , "\2", 2
            .Execute "(^12)^13", , , 1, , , , , , "\1", 2
            .Execute "(^13) ", , , , , , , , , "\1", 2

            .Execute "([0-90-9])、", , , 1, , , , , , "\1.", 2
            .Execute "([0-90-9]).([一-﨩])", , , 1, , , , , , "\1.\2", 2
            .Execute "(^13[0-90-9]{1,}).", , , 1, , , , , , "\1.", 2

            .Execute "([0-90-9]):([0-90-9])", , , 1, , , , , , "\1:\2", 2
            .Execute "([0-90-9]),([0-90-9])", , , 1, , , , , , "\1,\2", 2
            .Execute "([0-90-9])。([0-90-9])", , , 1, , , , , , "\1.\2", 2

            .Execute "附表", , , , , , , , , "附件", 2
            .Execute "(^13)附([::..、,,^13])", , , 1, , , , , , "\1附件\2", 2
            .Execute "(^13)附([  ^s^t0-90-9]{1,})", , , 1, , , , , , "\1附件\2", 2
            .Execute "(^13)附([::..、,,]^13)", , , 1, , , , , , "\1附件\2", 2

            .Execute "([二一])([零〇○0Oo])(??年)", , , 1, , , , , , "\1〇\3", 2
            .Execute "([二一]?)([零〇○0Oo])(?年)", , , 1, , , , , , "\1〇\3", 2
            .Execute "([二一]??)([零〇○0Oo])(年)", , , 1, , , , , , "\1〇\3", 2
            .Execute "?([0-90-9]{4})(?)([0-90-9]@号)", , , 1, , , , , , "〔\1〕\3", 2
            .Execute "(^13联)(系)(人:*^13?[一-﨩][一-﨩][一-﨩]:)", , , 1, , , , , , "\1 \2 \3", 2

            .Execute "[::] ", , , , , , , , , ":", 2
            .Execute ")^9", , , , , , , , , ")", 2
            .Execute " (“)", , , 1, , , , , , "\1", 2
            .Execute "(”) ", , , 1, , , , , , "\1", 2
            .Execute "(》)(《)", , , 1, , , , , , "\1、\2", 2
            .Execute "(。)((*))(^13)", , , 1, , , , , , "\2\1\3", 2
        End With
    End With

    Full2Half
    Half2Full

    Title1

    Title2345
    Selection.HomeKey Unit:=wdStory
    Title2345AutoNum

    称呼
    落款
    附件
    印发
    第一

    插入页码_公文一字线
    Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=False
    删除页眉横线
    插入页码

    TitleCancel
    CutLine
    TableTitle
    With doc
        If .Paragraphs(2).Range Like "*)?" Then .Paragraphs(2).Range.InsertBefore Text:=" "
    End With
    TitleExtend

    最后一磅
    显示页数
    FJTitle
    CutPage

    Selection.HomeKey Unit:=wdStory
End Sub
Sub PaperSetup()
    Dim s As Section
    For Each s In ActiveDocument.Sections
        With s.PageSetup
            If .Orientation = wdOrientPortrait Then
                .TopMargin = CentimetersToPoints(2.54)
                .BottomMargin = CentimetersToPoints(2.54)
                .LeftMargin = CentimetersToPoints(3.17)
                .RightMargin = CentimetersToPoints(3.17)
                .PageWidth = CentimetersToPoints(21)
                .PageHeight = CentimetersToPoints(29.7)
            Else
                .TopMargin = CentimetersToPoints(2.5)
                .BottomMargin = CentimetersToPoints(2.5)
                .LeftMargin = CentimetersToPoints(2.54)
                .RightMargin = CentimetersToPoints(2.54)
                .PageWidth = CentimetersToPoints(29.7)
                .PageHeight = CentimetersToPoints(21)
            End If
            .HeaderDistance = CentimetersToPoints(1.5)
            .FooterDistance = CentimetersToPoints(1.75)
        End With
    Next
End Sub
Sub 正文样式()
    Dim i As Paragraph, r As Range
    With Selection
        .ClearFormatting
        CommandBars.FindControl(ID:=122).Execute
        CommandBars.FindControl(ID:=123).Execute
        With .Font
            .Name = "仿宋"
            .Size = 16
            .Color = wdColorBlue
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
        With .ParagraphFormat
            .LineSpacing = LinesToPoints(1.5)
            .CharacterUnitFirstLineIndent = 2
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
        End With
        Set r = .Range
        For Each i In r.Paragraphs
            If Asc(i.Range) = 13 Then i.Range.Delete
        Next
    End With
End Sub
Sub Full2Half()
    Dim i As Paragraph, mt, r As Range, n%, m%
    With CreateObject("vbscript.regexp")
        .Pattern = "[A-Za-z0-9“”]"
        .Global = True
        .IgnoreCase = False
        .MultiLine = True
        For Each i In ActiveDocument.Paragraphs
            For Each mt In .Execute(i.Range.Text)
                m = mt.FirstIndex: n = mt.Length
                With ActiveDocument.Range(i.Range.Start + m, i.Range.Start + m + n)
                    If .Text Like "[“”]" Then .CharacterWidth = wdWidthFullWidth Else .CharacterWidth = wdWidthHalfWidth
                End With
            Next
        Next
    End With
End Sub
Sub Half2Full()
    Dim d, x, y, k, t, i%, j%
    x = Array(".", ",", ";", ":", "!", "?")
    y = Array("。", ",", ";", ":", "!", "?")
    Set d = CreateObject("Scripting.Dictionary")
    For i = 0 To UBound(x)
        d(x(i)) = y(i)
    Next
    k = d.keys: t = d.items
    With ActiveDocument.Content.Find
        For j = 0 To d.Count - 1
            .Execute "([一-﨩^13^11])\" & k(j) & "([0-9一-﨩^13^11])", , , 1, , , , , , "\1" & t(j) & "\2", 2
        Next
    End With
End Sub
Sub Title1()
    Dim doc As Document, r As Range
    Set doc = ActiveDocument
    With doc
        If Not .Paragraphs(1).Range.Information(12) Then Set r = .Paragraphs(1).Range Else Set r = .Tables(1).Range.Next(4, 1)
    End With
    With r
        If .Text Like "*[。:;,、!?…—.:;,!?]?" Or .Text Like "[一1][、..]*" Then Exit Sub
        If .End <> doc.Content.End Then
            If Not (.Next.Information(12) Or .Next(4, 1) Like "*[。:;,、!?…—.:;,!?]?" Or .Next(4, 1) Like "[一1][、..]*" Or .Next(4, 1) Like "([一1])*") Then .MoveEnd 4, 1
        End If
        If .End <> doc.Content.End Then
            If Not (.Next.Information(12) Or .Next(4, 1) Like "*[。:;,、!?…—.:;,!?]?" Or .Next(4, 1) Like "[一1][、..]*" Or .Next(4, 1) Like "([一1])*") Then .MoveEnd 4, 1
        End If
        If .End <> doc.Content.End Then
            .Characters.Last.InsertParagraphBefore
        End If
        .InsertParagraphBefore
        .Style = wdStyleHeading1
        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        With .Font
            .NameAscii = "Times New Roman"
            .Size = 22
            .Color = wdColorAutomatic
        End With
        With .ParagraphFormat
            .SpaceBeforeAuto = False
            .SpaceAfterAuto = False
            .SpaceBefore = 0
            .SpaceAfter = 0
            .LineSpacing = LinesToPoints(1.15)
            .Alignment = wdAlignParagraphCenter
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
        End With
        With .Paragraphs
            .First.Range.Font.Size = 21
            .Last.Range.Font.Size = 26
        End With
    End With
End Sub
Sub Title2345()
    Dim doc As Document, i&, s$
    Set doc = ActiveDocument
    For i = 1 To 4
        If i = 1 Then
            s = "^13[一二三四五六七八九十百零〇○Oo千]@、*^13"
        ElseIf i = 2 Then
            s = "^13([一二三四五六七八九十百零〇○Oo千]@)*^13"
        ElseIf i = 3 Then
            s = "^13[0-9]@.*^13"
        ElseIf i = 4 Then
            s = "^13([0-9]@)*^13"
        End If
        With Selection
            .HomeKey Unit:=wdStory
            With .Find
                .ClearFormatting
                .Text = s
                .Forward = True
                .MatchWildcards = True
                .Replacement.Text = ""
                Do While .Execute
                    With .Parent
                        .MoveStart
                        If Not .Information(12) Then
                            If .Paragraphs.Count = 1 Then
                                If i = 1 Then
                                    .Style = wdStyleHeading2
                                    .Font.Color = wdColorRed
                                ElseIf i = 2 Then
                                    .Style = wdStyleHeading3
                                    .Font.NameFarEast = "楷体"
                                    .Font.Color = wdColorPink
                                ElseIf i = 3 Then
                                    .Style = wdStyleHeading4
                                    With .Font
                                        .Name = "仿宋"
                                        .Size = 16
                                        .Color = wdColorGreen
                                    End With
                                ElseIf i = 4 Then
                                    .Style = wdStyleHeading5
                                    With .Font
                                        .Name = "仿宋"
                                        .Size = 16
                                        .Color = wdColorOrange
                                    End With
                                End If
                                If .Sentences(1) Like "*:??*" Then
                                    .MoveStart 1, InStr(.Text, ":")
                                    With .Font
                                        .Name = "仿宋"
                                        .Bold = False
                                        .Color = wdColorBlue
                                    End With
                                    If .Paragraphs(1).Range.Style Like "标题*" & "[23]" Then
                                        If .Text Like "*[。:;,、!?…—.:;,!?]?" Then
                                            .Characters.Last.Previous.Delete
                                        End If
                                    ElseIf .Paragraphs(1).Range.Style Like "标题*" & "[45]" Then
                                        If .Text Like "*[!。:;,、!?…—.:;,!?]?" Then
                                            If .Text Like "*[!0-9a-zA-Z]?" Then
                                                .Characters.Last.InsertBefore Text:="。"
                                            End If
                                        End If
                                    End If
                                Else
                                    If .Sentences.Count = 1 Then
                                        If .Text Like "*[。:;,、!?…—.:;,!?]?" Then .Characters.Last.Previous.Delete
                                    Else
                                        With doc.Range(Start:=.Sentences(1).End, End:=.Paragraphs(1).Range.End).Font
                                            .Name = "仿宋"
                                            .Bold = False
                                            .Color = wdColorBlue
                                        End With
                                    End If
                                End If
                                With .ParagraphFormat
                                    .SpaceBeforeAuto = False
                                    .SpaceAfterAuto = False
                                    .SpaceBefore = 0
                                    .SpaceAfter = 0
                                    .LineSpacing = LinesToPoints(1.5)
                                    .CharacterUnitFirstLineIndent = 2
                                    .AutoAdjustRightIndent = False
                                    .DisableLineHeightGrid = True
                                    .KeepWithNext = False
                                    .KeepTogether = False
                                End With
                                If .Style = "标题 2" Then
                                    With .ParagraphFormat
                                        .SpaceBefore = 3
                                        .SpaceAfter = 3
                                    End With
                                End If
                            End If
                        Else
                            .Tables(1).Range.Next.Select
                        End If
                        .EndKey Unit:=wdLine
                    End With
                Loop
            End With
        End With
    Next i
End Sub
Sub Title2345AutoNum()
    Dim doc As Document, r As Range, i As Paragraph, b&, c&, d&, e&
    Set doc = ActiveDocument
    With Selection
        .Expand 4
        .EndKey 6, 1
        Set r = .Range
    End With
    For Each i In r.Paragraphs
        With i.Range
            If Not .Information(12) Then
                If .Style = "标题 1" Or .Text Like "[!^13]附件*" Or .Text Like "附件*" Then
                    b = 0: c = 0: d = 0: e = 0
                ElseIf .Style = "标题 2" Then
                    c = 0: d = 0: e = 0
                    b = b + 1
                    With doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, "、")).End - 1)
                        .Text = b
                        .Delete
                        .Fields.Add Range:=i.Range, Text:="= " & b & " \* CHINESENUM3"
                    End With
                ElseIf .Style = "标题 3" Then
                    d = 0: e = 0
                    c = c + 1
                    With doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, ")")).End - 1)
                        .Text = c
                        .Delete
                        .Fields.Add Range:=i.Range, Text:="= " & c & " \* CHINESENUM3"
                        .InsertBefore Text:="("
                    End With
                ElseIf .Style = "标题 4" Then
                    e = 0
                    d = d + 1
                    doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, ".")).End - 1).Text = d
                ElseIf .Style = "标题 5" Then
                    e = e + 1
                    With doc.Range(Start:=.Characters(1).Start, End:=.Characters(InStr(i.Range, ")")).End - 1)
                        .Text = e
                        .InsertBefore Text:="("
                    End With
                End If
            End If
        End With
    Next
    doc.Fields.Unlink
End Sub
Sub TitleCancel()
    On Error Resume Next
    Dim i As Paragraph, j&, k&, x&
    For x = 2 To 5
        For Each i In ActiveDocument.Paragraphs
            With i.Range
                If .Style = "标题 " & x Then
                    If j = 0 Then
                        If .Next(4, 1).Style = "标题 " & x And .Sentences.Count = 1 And Not .Text Like "*:*" Then k = 1
                        j = 1
                    End If
                    If k = 1 Then .Select: 正文样式: If .Text Like "*[!。:;,、!?…—.:;,!?]?" And .Text Like "*[!0-9]?" Then .Characters.Last.InsertBefore Text:="。"
                ElseIf Right(.Style, 1) < x Then
                    j = 0
                    k = 0
                End If
            End With
        Next
        j = 0
        k = 0
    Next x
End Sub
Sub TitleExtend()
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Execute "^p^p", , , 0, , , 1
            If .Found = True Then
                With .Parent
                    .MoveEnd 1, -1
                    If .Paragraphs(1).Range.ComputeStatistics(statistic:=wdStatisticLines) = 1 Then
                        .MoveStart 5, -1
                        With .Find
                            .Execute "^w", , , , , , , , , "", 2
                            .Execute " ", , , , , , , , , "", 2
                        End With
                        If .Text Like "(*)?" Then
                            With .Font
                                .Size = 18
                                .NameFarEast = "楷体"
                            End With
                            .ParagraphFormat.SpaceBefore = 6
                            If Len(.Text) = 6 Then
                                .Characters(2).InsertAfter Text:=" "
                                .Characters(4).InsertAfter Text:=" "
                            End If
                        Else
                            TitleSpacing
                        End If
                    End If
                End With
            End If
        End With
    End With
End Sub
Sub TitleSpacing()
    Dim i&
    i = Len(Selection)
    With Selection
        If i = 3 Then
            .Characters(1).InsertAfter Text:="    "
        ElseIf i = 4 Then
            .Characters(1).InsertAfter Text:="   "
            .Characters(5).InsertAfter Text:="   "
        ElseIf i = 5 Or i = 6 Then
            .Characters(1).InsertAfter Text:="  "
            .Characters(4).InsertAfter Text:="  "
            .Characters(7).InsertAfter Text:="  "
            If i = 6 Then .Characters(10).InsertAfter Text:="  "
        ElseIf i = 7 Or i = 8 Then
            .Characters(1).InsertAfter Text:=" "
            .Characters(3).InsertAfter Text:=" "
            .Characters(5).InsertAfter Text:=" "
            .Characters(7).InsertAfter Text:=" "
            .Characters(9).InsertAfter Text:=" "
            If i = 8 Then .Characters(11).InsertAfter Text:=" "
        End If
    End With
End Sub
Sub CutLine()
    Dim r As Range, i&, j&
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Text = "^p"
            .Forward = True
            .MatchWildcards = False
            Do While .Execute
                With .Parent
                    If .Style <> "标题 1" Then
                        If Not .Information(12) Then
                            If .Paragraphs(1).Range.ComputeStatistics(statistic:=1) > 1 Then
                                .MoveStart 5, -1
                                If .Text Like "?[。:;,、!?…—.:;,!?]?" Or .Text Like "??" Then
                                    .Expand 4
                                    Set r = .Range
                                    i = r.ComputeStatistics(statistic:=1)
                                    Do While .Text Like "[!一-﨩]*"
                                        .MoveStart
                                    Loop
                                    With .Font
                                        Do
                                            j = j + 1
                                            If j = 3 Then Exit Do
                                            .Spacing = -0.4
                                        Loop Until r.ComputeStatistics(statistic:=1) = i - 1
                                    End With
                                End If
                                .Collapse 0
                                If .End = ActiveDocument.Content.End - 1 Then Exit Sub
                            End If
                        End If
                    End If
                End With
            Loop
        End With
    End With
End Sub
Sub TableTitle()
    With ActiveDocument
        If Not .Paragraphs(1).Range.Information(12) And Len(.Paragraphs(1).Range) = 1 Then
            If Not .Paragraphs(3).Range.Information(12) And Len(.Paragraphs(3).Range) = 1 Then
                If .Paragraphs(4).Range.Information(12) Then
                Else
                    If .Paragraphs(5).Range.Information(12) Then
                        With .Paragraphs(4).Range
                            With .Font
                                .NameFarEast = "宋体"
                                .NameAscii = "Times New Roman"
                                .Size = 12
                            End With
                            With .ParagraphFormat
                                .CharacterUnitFirstLineIndent = 0
                                .FirstLineIndent = 0
                                .Space1
                            End With
                        End With
                    Else
                        Exit Sub
                    End If
                End If
                .Paragraphs(1).Range.Delete
                With .Paragraphs(1).Range
                    If .ComputeStatistics(1) = 1 Then
                        .Parent.Paragraphs(2).Range.Font.Size = 12
                    Else
                        .Parent.Paragraphs(2).Range.Font.Size = 16
                    End If
                End With
            End If
        End If
    End With
End Sub
Sub 称呼()
    With Selection.Find
        .ClearFormatting
        .Execute "^13^13*:^13", , , 1, , , 1
        If .Found = True Then
            With .Parent
                .MoveStart 1, 2
                If .Range.ComputeStatistics(1) < 3 Then
                    With .ParagraphFormat
                        .CharacterUnitFirstLineIndent = 0
                        .FirstLineIndent = CentimetersToPoints(0)
                    End With
                End If
            End With
        End If
    End With
End Sub
Sub 落款()
    Dim r As Range
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Text = "^13[0-9]{4}年[0-9]{1,2}月[0-9]{1,2}日^13"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                With .Parent
                    .MoveStart
                    If .Style = "标题 1" Then
                        .EndKey 5
                    Else
                        .Font.Color = wdColorPink
                        With .ParagraphFormat
                            .Alignment = wdAlignParagraphRight
                            .CharacterUnitRightIndent = 5.9
                        End With
                        Set r = .Previous(4, 1)
                        With r
                            If r Like "*[!。:;,、!?…—.:;,!?]?" Then
                                .Font.Color = wdColorRed
                                .InsertBefore Text:=vbCr & vbCr & vbCr
                                .SetRange Start:=.Paragraphs.Last.Range.Start, End:=.Paragraphs.Last.Range.End
                                With .ParagraphFormat
                                    If Len(r) = 10 Then
                                        .CharacterUnitFirstLineIndent = 13.55
                                    Else
                                        .CharacterUnitFirstLineIndent = 11
                                    End If
                                End With
                            Else
                                .InsertAfter Text:=vbCr
                                Selection.MoveStart
                            End If
                        End With
                        Exit Sub
                    End If
                End With
            Loop
        End With
    End With
End Sub
Sub 附件()
    Dim s As Range, r As Range, i As Paragraph, k&, n&, t$
    With Selection
        If .Type = wdSelectionIP Then Exit Sub Else Set s = .Range
        .EndKey 5
        With .Find
            .ClearFormatting
            .Text = "[^13^12]附件*^13"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                With .Parent
                    If Asc(.Text) = 13 Then
                        .Characters(1).InsertAfter Text:=Chr(12)
                        .MoveStart 1, 2
                    Else
                        .MoveStart
                    End If
                    .MoveEnd 1, -1
                    If .Previous.Previous.Previous.Information(12) Then .Previous.Previous.Delete
                    n = n + 1
                    .Text = "附件" & n
                    With .Font
                        .NameFarEast = "黑体"
                        .NameAscii = "Times New Roman"
                        .Bold = True
                        .Color = wdColorRed
                    End With
                    With .ParagraphFormat
                        .CharacterUnitFirstLineIndent = 0
                        .FirstLineIndent = CentimetersToPoints(0)
                        .Space1
                    End With
                    .Next(4, 1).Select
                    If Not (.Next.Information(12) Or .Next(4, 1) Like "*[。:;,、!?…—.:;,!?_  ^s^t()]*" Or .Next(4, 1) Like "[一1][、..]*" Or .Next(4, 1) Like "([一1])*") Then
                        .MoveEnd 4, 1
                        .Paragraphs(1).Range.Characters.Last.Delete
                    End If
                    t = t & n & "." & .Text
                    .Style = wdStyleSubtitle
                    With .Font
                        .NameAscii = "Times New Roman"
                        .Size = 20
                        .Color = wdColorAutomatic
                    End With
                    With .ParagraphFormat
                        .SpaceBefore = 0
                        .SpaceAfter = 0
                        .LineSpacing = LinesToPoints(1.15)
                        .AutoAdjustRightIndent = False
                        .DisableLineHeightGrid = True
                    End With
                    If .Text Like "*)?" And .Range.ComputeStatistics(statistic:=1) Then .InsertBefore Text:=" "
                    .InsertParagraphBefore
                    .Characters.Last.InsertBefore Text:=vbCr
                    .EndKey 5
                    k = 1
                End With
            Loop
        End With
        If k = 0 Then Exit Sub
        If n = 1 Then .Previous(4, 1).Previous(4, 1).Previous(4, 1).Characters.Last.Previous.Delete: t = Right(t, Len(t) - 2)
'''
        s.Select
        .HomeKey 6, 1
        With .Find
            .ClearFormatting
            .Execute "^13附件", , , 1, , , 1
            If .Found = True Then
                With .Parent
                    .MoveStart
                    Do
                        .MoveDown 4, 1, 1
                    Loop Until .Text Like "*" & vbCr & vbCr
                    .MoveEnd 1, -1
                    .Text = vbCr & "附件:" & t
                    .MoveStart
                End With
            Else
                s.Previous(4, 1).Previous.Previous.Previous.Select
                With .Parent
                    .Text = vbCr & "附件:" & t & vbCr
                    .MoveStart
                    .MoveEnd 1, -1
                End With
            End If
        End With
        Set r = .Range
        r.Font.Color = wdColorViolet
        If n = 1 Then
            With .ParagraphFormat
                .CharacterUnitLeftIndent = 3.05
                If .Parent.Text Like "附件:20##*" Then
                    .CharacterUnitFirstLineIndent = -2.99
                Else
                    .CharacterUnitFirstLineIndent = -3.03
                End If
            End With
            If .Range.ComputeStatistics(statistic:=1) > 1 Then
                .Characters.Last.Select
                .MoveStart 5, -1
                If Len(.Text) = 2 Then
                    .MoveStart 5, -1
                    If .Text Like "附件:*" Then .MoveStart 1, 4 Else .MoveStart
                    .Font.Spacing = -0.4
                End If
            End If
        Else
            With .Paragraphs(1).Range.ParagraphFormat
                .CharacterUnitLeftIndent = 3.05
                If .Parent Like "*20##*" Then .CharacterUnitFirstLineIndent = -4.53 Else .CharacterUnitFirstLineIndent = -4.65
            End With
            r.MoveStart 4, 1
            For Each i In r.Paragraphs
                With i.Range
                    With .ParagraphFormat
                        If .Parent Like "*20##*" Then
                            .CharacterUnitLeftIndent = 7.6
                            .CharacterUnitFirstLineIndent = -1.5
                        Else
                            .CharacterUnitLeftIndent = 7.65
                            .CharacterUnitFirstLineIndent = -1.56
                        End If
                    End With
                    If .ComputeStatistics(statistic:=1) > 1 Then
                        .Characters.Last.Select
                        With Selection
                            .MoveStart 5, -1
                            If Len(.Text) = 2 Then
                                .MoveStart 5, -1
                                If .Text Like "#.*" Then .MoveStart 1, 3 Else .MoveStart
                                .Font.Spacing = -0.4
                            End If
                        End With
                    End If
                End With
            Next
        End If
    End With
End Sub
Sub 缩成一行()
    With Selection
        .Expand 4
        If .Information(12) Then .MoveEnd 1, -1
        With .Font
            If .Spacing = "9999999" Then .Spacing = 0
            If .Scaling = "9999999" Then .Scaling = 100
            .Spacing = -0.5
            Do Until .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) = 1
                .Scaling = .Scaling - 2
            Loop
        End With
    End With
End Sub
Sub 印发()
    Dim i&, r As Range
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Text = "[0-9]{4}年[0-9]{1,2}月[0-9]{1,2}日印发"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                With .Parent
                    If .Information(12) Then .Tables(1).Rows.ConvertToText Separator:=wdSeparateByParagraphs, NestedTables:=True
                    .Expand 4
                    .Text = Replace(.Text, " ", "")
                    .Text = Replace(.Text, " ", "")
                    .Text = Replace(.Text, vbTab, "")
                    .Text = Replace(.Text, ChrW(160), "")
                    If .Text Like "*日印发" & vbCr Then Exit Do Else .Collapse 0
                End With
            Loop
            If .Found = False Then Exit Sub
        End With
        .Characters(InStr(.Text, "2")).InsertBefore Text:=" "
        If .Previous(4, 1) Like "*[!。]?" Then .Previous(4, 1).Characters.Last.InsertBefore Text:="。"
        If .Previous(4, 1).Text Like "抄送:*" Then .MoveStart 4, -1
        .InsertBefore Text:=vbCr & vbCr & vbCr
        .MoveStart 1, 3
        .ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
         With .Font
            .Size = 14
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
        With .ParagraphFormat
            .Space1
            .CharacterUnitLeftIndent = 1
            .CharacterUnitRightIndent = 1
            .CharacterUnitFirstLineIndent = -3.05
            .LineUnitBefore = 0.2
            .LineUnitAfter = 0.2
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
        End With
        With .Tables(1)
            .PreferredWidthType = wdPreferredWidthPoints
            .PreferredWidth = CentimetersToPoints(14.7)
            .Rows.Alignment = wdAlignRowCenter
            .Range.Font.Color = wdColorBlue
        End With
        If .Cells.Count = 2 Then
            Options.DefaultBorderLineWidth = wdLineWidth100pt
            .Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
            .Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
            .Tables(1).Range.Cells(2).Select
            Options.DefaultBorderLineWidth = wdLineWidth025pt
            .Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
        ElseIf .Cells.Count = 1 Then
            Options.DefaultBorderLineWidth = wdLineWidth100pt
            .Borders(wdBorderTop).LineStyle = Options.DefaultBorderLineStyle
            .Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle
        End If
        ActiveWindow.View.TableGridlines = False
        .Paragraphs(1).Range.Select
        .MoveEnd 1, -1
        i = InStr(.Text, " ")
        Do
            .Characters(i).InsertAfter Text:=" "
        Loop Until .Range.ComputeStatistics(statistic:=wdStatisticLines) = 2
        Do
            .Characters(i).Delete
        Loop Until .Range.ComputeStatistics(statistic:=wdStatisticLines) = 1
    End With
End Sub
Sub 第一()
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Text = "^13第[一二三四五六七八九十][!一-﨩][一-﨩]*。"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                With .Parent
                    If Not .Information(12) Then
                        .MoveStart
                        .Font.Bold = True
                        .Font.Color = wdColorBrown
                        .Characters(3).Text = ","
                        .Collapse 0
                    End If
                End With
            Loop
        End With
    End With
End Sub
Sub 插入页码_公文一字线()
    Dim s As Section
    For Each s In ActiveDocument.Sections
        s.Footers(1).Range.Delete
        With s.Footers(1).Range.Sections(1).Headers(1).PageNumbers
            .NumberStyle = wdPageNumberStyleArabic
            .HeadingLevelForChapter = 0
            .IncludeChapterNumber = False
            .ChapterPageSeparator = wdSeparatorHyphen
            .RestartNumberingAtSection = False
            .StartingNumber = 0
        End With
        s.Footers(1).PageNumbers.Add 2, True
        With s.Footers(1).Range.Frames(1).Range
            .Select
            With Selection
                .TypeText Text:=Chr(-24159)
                .InsertSymbol Font:="宋体", CharacterNumber:=8212, Unicode:=True
                .TypeText Text:=" "
                .EndKey 5
                .TypeText Text:=" "
                .InsertSymbol Font:="宋体", CharacterNumber:=8212, Unicode:=True
                .TypeText Text:=Chr(-24159)
                .Expand 4
                With .Font
                    .Name = "宋体"
                    .Size = 14
                End With
                .ParagraphFormat.CharacterUnitRightIndent = 1.5
            End With
        End With
    Next
    ActiveWindow.ActivePane.Close
    ActiveWindow.View.Type = wdPrintView
End Sub
Sub 删除页眉横线()
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub 插入页码()
    With ActiveDocument
        If .Sections.Count = 1 Then
            If .Content.Information(wdNumberOfPagesInDocument) > 2 And .Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbCr Then
                .Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight, FirstPage:=True
            ElseIf .Content.Information(wdNumberOfPagesInDocument) <= 2 And .Sections(1).Footers(wdHeaderFooterPrimary).Range.Text <> vbCr Then
                .StoryRanges(wdPrimaryFooterStory).Frames(1).Cut
            End If
        End If
    End With
End Sub
Sub 最后一磅()
    With ActiveDocument.Paragraphs.Last.Range
        If Len(.Text) > 1 Then Exit Sub
        .Font.Size = 1
        .ParagraphFormat.LineSpacing = LinesToPoints(0.06)
        .Select
    End With
    取消网格
End Sub
Sub 显示页数()
    Dim i&
    i = ActiveDocument.Content.Information(wdNumberOfPagesInDocument)
    With ActiveWindow.ActivePane.View.Zoom
        If i <= 6 Then
            .PageColumns = i: .PageRows = 1
        ElseIf i = 7 Or i = 9 Or i = 11 Or i = 13 Or i = 15 Then
            .PageColumns = (i + 1) / 2: .PageRows = 2
        ElseIf i = 8 Or i = 10 Or i = 12 Or i = 14 Or i = 16 Then
            .PageColumns = i / 2: .PageRows = 2
        ElseIf i >= 17 Then
            .PageColumns = 15
        End If
    End With
End Sub
Sub FJTitle()
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Text = "^12附件*^12附件"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                With .Parent
                    .MoveStart
                    .MoveEnd 1, -2
                    FJRange
                    .HomeKey 5
                End With
            Loop
            .ClearFormatting
            .Execute "^12附件", , , 1, , , 1
            If .Found = True Then
                With .Parent
                    .MoveStart
                    .EndKey 6, 1
                    FJRange
                End With
            End If
        End With
    End With
End Sub
Sub FJRange()
    Dim doc As Document, r As Range, x&, y&
    Set doc = ActiveDocument
    Set r = Selection.Range
    With r
        If .Tables.Count > 0 Then
            If .Paragraphs(6).Range.Information(12) And Not .Paragraphs(5).Range.Information(12) Then
                .Paragraphs(5).Range.Select: FJText
            ElseIf .Paragraphs(7).Range.Information(12) And Not .Paragraphs(6).Range.Information(12) Then
                .Paragraphs(5).Range.Select: Selection.MoveEnd 4, 1: FJText
            End If
            .Tables(1).Range.Next(4, 1).Select
            With Selection
                If Asc(.Text) = 12 Or .End = doc.Content.End Then GoTo sf
                .ParagraphFormat.Space1
                If Not .End = doc.Content.End Then
                    If Not Asc(.Next) = 12 Then .MoveEnd 4, 1
                End If
                If Not .End = doc.Content.End Then
                    If Not Asc(.Next) = 12 Then .MoveEnd 4, 1
                End If
                If Not .End = doc.Content.End Then
                    If Not Asc(.Next) = 12 Then .MoveEnd 4, 1
                End If
                If Not .End = doc.Content.End Then
                    If Not (Asc(.Next) = 12) Then GoTo sf
                End If
                .MoveStart
                FJText
            End With
sf:
            x = .Characters.First.Information(3)
            y = .Characters.Last.Information(3)
            If x < y Then
                Do
                    .Paragraphs(3).Range.Select
                    缩减一行
                    With Selection
                        If .Previous.Font.Size = 1 Then Exit Do
                        .Previous.Font.Size = .Previous.Font.Size - 1
                        .Next.Font.Size = .Next.Font.Size - 1
                    End With
                Loop Until .Characters.Last.Information(3) = x
            End If
        End If
    End With
End Sub
Sub FJText()
    With Selection
        With .Font
            .NameFarEast = "宋体"
            .NameAscii = "Times New Roman"
            .Size = 12
        End With
        With .ParagraphFormat
            .CharacterUnitFirstLineIndent = 0
            .FirstLineIndent = 0
            .Space1
        End With
    End With
End Sub
Sub CutPage()
    Dim s As Range, p&
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Execute "^12附件", , , 1, , , 1
            If .Found = True Then .Parent.Characters(1).Select Else ActiveDocument.Characters.Last.Select
        End With
        Set s = .Range
        p = s.Information(3)
        If p >= 3 And p Mod 2 = 1 Then
            .GoTo What:=wdGoToPage, Which:=wdGoToNext, Name:=p
            ActiveDocument.Range(Start:=.Start, End:=s.End).Select
            If .Range.ComputeStatistics(statistic:=1) < 12 Then
                .HomeKey 6
                减少一页
            End If
        End If
    End With
End Sub
Sub 普通()
    Dim t!, x&, y&, s!
    x = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
    t = Timer
    外核
    s = Round(Timer - t, 2)
    y = ActiveDocument.BuiltInDocumentProperties(wdPropertyWords)
    显示页数
    ActiveWindow.DocumentMapPercentWidth = 20
    MsgBox "排版完毕! 用时 " & s & " 秒! 共 " & Selection.Information(wdNumberOfPagesInDocument) & " 页!     " & vbCr & vbCr & "排版前字数 = " & x & vbCr & "排版后字数 = " & y, 0 + 48
    ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
End Sub
Sub 外核()
    核心
    Dim i As Paragraph, t As Table
    For Each i In ActiveDocument.Paragraphs
        With i.Range
            If Not .Information(12) Then
                If .Style = "标题 2" Then
                    .ParagraphFormat.CharacterUnitFirstLineIndent = 1.75
                ElseIf .Style = "标题 3" Then
                    If .Sentences.Count = 1 Then
                        .ParagraphFormat.CharacterUnitFirstLineIndent = 1.74
                    Else
                        .ParagraphFormat.CharacterUnitFirstLineIndent = 1.75
                    End If
                ElseIf .Style Like "标题 " & "[45]" Or .Style = "正文" Then
                    With .Font
                        .NameFarEast = "宋体"
                        .NameAscii = "Times New Roman"
                        .Size = 14
                    End With
                End If
                If .Style = "标题 4" Then .ParagraphFormat.CharacterUnitFirstLineIndent = 1.99
                If .Style Like "标题 [23]" Then
                    If .Sentences.Count > 1 Then
                        With ActiveDocument.Range(Start:=.Sentences(1).End, End:=.Paragraphs(1).Range.End).Font
                            .NameFarEast = "宋体"
                            .NameAscii = "Times New Roman"
                        End With
                    End If
                End If
                If .Style <> "标题 1" Then .ParagraphFormat.LineSpacing = LinesToPoints(1.25)
            End If
        End With
    Next
    For Each t In ActiveDocument.Tables
        t.Range.Next.Font.Size = 4
    Next
    切换页码
    With Selection.Sections(1).Headers(1).PageNumbers
        .NumberStyle = wdPageNumberStyleNumberInDash
        .HeadingLevelForChapter = 0
        .IncludeChapterNumber = False
        .ChapterPageSeparator = wdSeparatorHyphen
        .RestartNumberingAtSection = False
        .StartingNumber = 0
    End With
    Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=False
    插入页码
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Execute "^13^13^13^13*^13", , , 1, , , 1
            If .Found = True Then
                With .Parent
                    .MoveStart 1, 4
                    With .ParagraphFormat
                        If Len(.Parent) = 10 Then
                            .CharacterUnitFirstLineIndent = 16.65
                        Else
                            .CharacterUnitFirstLineIndent = 14
                        End If
                    End With
                End With
            End If
        End With
        最后一磅
        显示页数
        .HomeKey 6
    End With
End Sub
Sub 切换页码()
    If ActiveDocument.Sections(1).Footers(wdHeaderFooterPrimary).Range.Text = vbCr Then
        Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberRight, FirstPage:=True
        ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
        Selection.ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
    Else
        ActiveDocument.StoryRanges(wdPrimaryFooterStory).Frames(1).Cut
    End If
End Sub
Sub 另存为()
    Dim i$
    ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
    With ActiveDocument
        i = .FullName
        If i Like "*:*" Then
            If .Saved = False Then .SaveAs FileName:=i, FileFormat:=wdFormatDocument
        Else
            .Save
        End If
    End With
End Sub
Sub 关闭不保存()
    ActiveDocument.Close savechanges:=wdDoNotSaveChanges
End Sub
Sub 重新打开()
    Dim i$
    With ActiveDocument
        i = .FullName
        If i Like "*:*" Then
            If .Saved = False Then
                .Close savechanges:=wdDoNotSaveChanges
                Documents.Open FileName:=i
            End If
        End If
    End With
End Sub
Sub 打印关闭不保存()
    With ActiveDocument
        .PrintOut
        .Close savechanges:=wdDoNotSaveChanges
    End With
End Sub
Sub 打印N份关闭不保存()
    Dim i$
    i = InputBox("", "请输入打印份数!", "3")
    If i = "" Then End
    With ActiveDocument
        .PrintOut Copies:=i
        .Close savechanges:=wdDoNotSaveChanges
    End With
End Sub
Sub 打印当前页()
    Application.PrintOut FileName:="", Range:=wdPrintCurrentPage
End Sub
Sub 表格处理()
    Dim t As Table, c As Cell, a&, e&, i As Paragraph, j&, k&, x&, y&, z&
    If Selection.Information(12) Then a = 1
    For Each t In ActiveDocument.Tables
        If a = 1 Then Set t = Selection.Tables(1)
        With t
            '取消环绕
            With .Rows
                .WrapAroundText = False
                .Alignment = wdAlignRowLeft
                .LeftIndent = CentimetersToPoints(0)
            End With

            '判断表格是否规则(e=1=规则/e=0=不规则)
            With .Range
                With .Find
                    .Execute "^13", , , , , , , , , "^p", 2
                    .Execute "^11", , , , , , , , , "^p", 2
                End With
                x = .Information(wdEndOfRangeRowNumber)
                y = .Information(wdEndOfRangeColumnNumber)
                z = .Cells.Count
            End With
            If x <> 1 Then
                If z = x * y Then
                    For k = 1 To y
                        For j = 1 To x - 1
                            If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
                            If e = 0 Then Exit For
                        Next j
                        If e = 0 Then Exit For
                    Next k
                Else
                    e = 0
                End If
            Else
                e = 1
            End If

            '清除空格
            If Asc(.Range.Next) <> 13 Then .Range.Next.InsertBefore Text:=vbCr
            .Select
            Selection.MoveEnd
            CommandBars.FindControl(ID:=122).Execute
            Selection.Characters.Last.ParagraphFormat.Alignment = wdAlignParagraphJustify
            .Select

            '清除格式
            Selection.ClearFormatting
            With .Range
                With .Font
                    .NameAscii = "Times New Roman"
                    .Size = 12
                    .Color = wdColorBlue
                    .Kerning = 0
                    .DisableCharacterSpaceGrid = True
                End With
                With .ParagraphFormat
                    .Alignment = wdAlignParagraphCenter
                    .AutoAdjustRightIndent = False
                    .DisableLineHeightGrid = True
                End With
                .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            End With

            .LeftPadding = CentimetersToPoints(0.19)
            .RightPadding = CentimetersToPoints(0.19)

            .AutoFitBehavior (wdAutoFitContent)
            .Select
            .AutoFitBehavior (wdAutoFitWindow)

            If e = 1 Then
                '行高最小值
                With .Rows
                    .HeightRule = wdRowHeightAtLeast
                    .Height = CentimetersToPoints(0.9)
                End With
                '表头加粗
                If Len(.Cell(2, 2).Range) > 2 Then
                    With .Rows(1).Range.Font
                        .NameFarEast = "黑体"
                        .Bold = True
                        .Color = wdColorRed
                    End With
                End If
            End If

            '删除单元格空段
            For Each c In .Range.Cells
                For Each i In c.Range.Paragraphs
                    If Asc(i.Range) = 13 And Len(i.Range) = 1 Then i.Range.Delete
                Next
                With c.Range.Paragraphs
                    If .Count > 1 And Len(.Last.Range) = 2 Then .Last.Previous.Range.Characters.Last.Delete
                End With
            Next
        End With
        If a = 1 Then Exit For
    Next
    行高热键
End Sub
Sub 取消标题()
    ActiveDocument.Content.InsertParagraphAfter
    Dim i$, j$, k&, r As Range, s&, t As Range
    With Selection
        If .Type = wdSelectionIP Then
            i = .Style
            If Not i Like "标题*" Then MsgBox "无标题!", 0 + 16: End
            j = MsgBox("<是>:全文    <否>:光标后    <取消>:光标前", 3 + 48, "取消标题")
            If j = 6 Then
                .WholeStory
            ElseIf j = 7 Then
                .Expand 4
                .EndKey 6, 1
            Else
                .HomeKey 6, 1
                If Asc(.Characters.Last) <> 13 Then .Expand 4
            End If
        Else
            .Expand 4
            k = 1
        End If
        Set r = .Range
        Set t = .Range
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Style = "正文"
            .Text = ""
            .Format = True
            .Forward = True
            .MatchWildcards = False
            Do While .Execute
                With .Parent
                    If .Information(12) Then
                        .Tables(1).Range.Next.Select
                        If Len(.Text) = 1 Then .Next.Select
                        .HomeKey 5
                    Else
                        s = .Font.Size
                        Exit Do
                    End If
                End With
            Loop
        End With
        If Not (s = 16 Or s = 14) Then s = 16
    End With
    If k = 1 Then GoTo ks
    With r.Find
        .ClearFormatting
        .Style = i
        .Text = ""
        .Format = True
        .Forward = True
        .MatchWildcards = False
        Do While .Execute
ks:
            r.Select
            正文样式
            If s = 14 Then
                With r.Font
                    .NameFarEast = "宋体"
                    .NameAscii = "Times New Roman"
                    .Size = 14
                End With
                r.ParagraphFormat.LineSpacing = LinesToPoints(1.25)
            End If
            If k = 1 Then
                r.Find.Execute "([!。:;,、!?…—.:;,\!\?])(^13)", , , 1, , , , , , "\1。\2", 2
                If r Like "*" & vbCr & vbCr Then r.Characters.Last.Previous.Delete
                GoTo de
            End If
            If r Like "*[!。:;,、!?…—.:;,!?]?" Then r.Characters.Last.InsertBefore Text:="。"
            r.SetRange Start:=r.End, End:=t.End
            If Len(r) < 2 Then GoTo de
            If r.End <> ActiveDocument.Content.End Then
                If r.Next(4, 1).Text = vbCr Then r.MoveEnd
            End If
        Loop
    End With
de:
    ActiveDocument.Characters.Last.Delete
End Sub
Sub 增加段前间距()
    Selection.ParagraphFormat.SpaceBefore = 6
End Sub
Sub 减少首行缩进()
    Selection.ParagraphFormat.CharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent - 0.05
End Sub
Sub 减少行距()
    With Selection
        If .Type = wdSelectionIP Then 选择正文
        取消网格
        With .Paragraphs
            If .LineSpacing <= 0.96 Then End
            If .LineSpacing = "9999999" Then .LineSpacing = LinesToPoints(1.25)
            .LineSpacing = LinesToPoints(.LineSpacing / 12 - 0.02)
        End With
    End With
End Sub
Sub 增加行距()
    With Selection
        If .Type = wdSelectionIP Then 选择正文
        取消网格
        With .Paragraphs
            If .LineSpacing = "9999999" Then .LineSpacing = LinesToPoints(1.25)
            .LineSpacing = LinesToPoints(.LineSpacing / 12 + 0.02)
        End With
    End With
End Sub
Sub 选择正文()
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Execute "^12附件", , , 0, , , 1
            If .Found = True Then .Parent.HomeKey 6, 1 Else .Parent.EndKey 6, 1
        End With
        Do Until Not (.Paragraphs(1).Range.Style = "标题 1" Or .Paragraphs(1).Range.Style = "副标题")
            .MoveStart 4, 1
        Loop
    End With
End Sub
Sub 取消网格()
    With Selection
        If .Type = wdSelectionIP Then 选择正文
        With .Font
            .Kerning = 0
            .DisableCharacterSpaceGrid = True
        End With
        With .ParagraphFormat
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
        End With
    End With
End Sub
Sub 减少字符缩放()
    With Selection
        If .Type = wdSelectionIP Then .Expand 4
        With .Font
            If .Scaling <= 6 Then End
            If .Scaling = "9999999" Then .Scaling = 100
            .Scaling = .Scaling - 5
        End With
    End With
End Sub
Sub 增加字符缩放()
    With Selection
        If .Type = wdSelectionIP Then .Expand 4
        With .Font
            If .Scaling >= 600 Then End
            If .Scaling = "9999999" Then .Scaling = 100
            .Scaling = .Scaling + 5
        End With
    End With
End Sub
Sub 标准字符缩放()
    Selection.Font.Scaling = 100
End Sub
Sub 减少字符间距()
    With Selection
        If .Type = wdSelectionIP Then .Expand 4
        With .Font
            If .Spacing = "9999999" Then .Spacing = 0
            .Spacing = .Spacing - 0.1
        End With
    End With
End Sub
Sub 增加字符间距()
    With Selection
        If .Type = wdSelectionIP Then .Expand 4
        With .Font
            If .Spacing = "9999999" Then .Spacing = 0
            .Spacing = .Spacing + 0.2
        End With
    End With
End Sub
Sub 粘贴无格式文本()
    If Documents.Count = 0 Then Documents.Add
    Selection.PasteAndFormat Type:=wdFormatPlainText
End Sub
Sub 删除所有空格()
    With Selection
        If .Type = wdSelectionIP Then .WholeStory
        With .Find
            .ClearFormatting
            .Execute "^w", , , 0, , , , , , "", 2
            .Execute " ", , , 0, , , , , , "", 2
        End With
    End With
End Sub
Sub 切换标题副标题()
    With Selection
        .Expand 4
        If .Style <> ActiveDocument.Styles(wdStyleSubtitle) Then
            .Style = ActiveDocument.Styles(wdStyleSubtitle)
        Else
            .Style = ActiveDocument.Styles(wdStyleTitle)
        End If
        .Font.NameAscii = "Times New Roman"
        With .ParagraphFormat
            .SpaceBeforeAuto = False
            .SpaceAfterAuto = False
            .SpaceBefore = 0
            .SpaceAfter = 0
            .LineSpacing = LinesToPoints(1.25)
            .AutoAdjustRightIndent = False
            .DisableLineHeightGrid = True
        End With
    End With
End Sub
Sub 切换页眉()
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    With Selection.ParagraphFormat.Borders(wdBorderBottom)
        If .LineStyle = wdLineStyleNone Then .LineStyle = wdLineStyleSingle Else .LineStyle = wdLineStyleNone
    End With
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
Sub 减少一页()
    Dim x&, y&, i!, j&
    With Selection
        If .Type = wdSelectionIP Then 选择正文
        If .End <> ActiveDocument.Content.End Then
            If Asc(.Next) = 12 Then .MoveEnd: j = 1
        End If
        With .Find
            .ClearFormatting
            If .Parent.Information(4) = 2 Then
                .Execute "^p^p^p^p", , , 0, , , , , , "^p^p", 2
            Else
                .Execute "^p^p^p^p", , , 0, , , , , , "^p^p^p", 2
            End If
        End With
        x = .Characters.First.Information(3)
        y = .Characters.Last.Information(3)
        If x = y Then GoTo js
        With .ParagraphFormat
            If .LineSpacing = "9999999" Then .LineSpacing = LinesToPoints(1.5)
            i = 1.5
            Do
                i = i - 0.01
                .LineSpacing = LinesToPoints(i)
                If Round(.LineSpacing / 12, 2) <= 1 Then .Space1: Exit Sub
            Loop Until .Parent.Characters.Last.Information(3) = y - 1
        End With
js:
        If j = 1 Then
            If .Characters.Last.Next.Text = "附" Then
                .Characters.Last.ParagraphFormat.Space1
            End If
        End If
        .HomeKey 6
    End With
    插入页码
End Sub
Sub 缩减一行()
    Dim r As Range, s As Range, i&, j&
    With Selection
        If .ParagraphFormat.Alignment = wdAlignParagraphCenter Then j = 0 Else j = 1
        If .Information(12) Then
            .MoveEndUntil cset:=vbCr, Count:=wdForward
            .MoveStart 5, -1
        Else
            .Expand 4
        End If
        With .Font
            If .Spacing = "9999999" Then .Spacing = 0
            If .Scaling = "9999999" Then .Scaling = 100
        End With
        Set s = .Range
        i = s.ComputeStatistics(statistic:=wdStatisticLines)
        If i = 1 Or i = 0 Then Exit Sub
        If j = 1 Then .MoveStart 1, 1
        Set r = .Range
        With r.Font
            If j = 0 Then
                .Spacing = -0.5
                Do Until r.ComputeStatistics(statistic:=wdStatisticLines) = i - 1
                    .Scaling = .Scaling - 2
                Loop
            Else
                Do
                    .Spacing = .Spacing - 0.1
                Loop Until s.ComputeStatistics(statistic:=wdStatisticLines) = i - 1
            End If
        End With
    End With
End Sub
Sub 纵横转换()
    With Selection
        If .Type <> wdSelectionIP Then
            ActiveDocument.Range(Start:=.Start, End:=.Start).InsertBreak Type:=wdSectionBreakNextPage
            .Start = .Start + 1
            If .End <> ActiveDocument.Content.End Then
                ActiveDocument.Range(Start:=.End, End:=.End).InsertBreak Type:=wdSectionBreakNextPage
            End If
        End If
        With .PageSetup
            If .Orientation = wdOrientPortrait Then .Orientation = wdOrientLandscape Else .Orientation = wdOrientPortrait
        End With
    End With
End Sub
Sub m2m3上标()
    With Selection
        If .Type = wdSelectionIP Then .HomeKey 6
        With .Find
            .ClearFormatting
            .Execute "m2", , , 1, , , , , , "m" & ChrW(178), 2
            .Execute "m3", , , 1, , , , , , "m" & ChrW(179), 2
        End With
    End With
End Sub
Sub 发文字号()
    核心
    With ActiveDocument
        .Content.InsertBefore Text:=vbCr & "XXX发〔" & Format(Date, "yyyy") & "〕" & "X号" & vbCr
        .Paragraphs(1).Range.Font.Size = 102
        .Paragraphs(3).Range.Font.Size = 40
        With .Paragraphs(2).Range.Font
            .Size = 16
            .NameFarEast = "仿宋"
        End With
        .Range(Start:=0, End:=.Paragraphs(3).Range.End).Font.NameAscii = "Times New Roman"
    End With
End Sub
Sub 行高循环()
    CursorIn
    With Selection
        If .Type = wdSelectionIP Then .Tables(1).Select
        If .Rows.HeightRule = 1 Or .Rows.HeightRule = 2 Then
            If .Rows.Height >= CentimetersToPoints(1.2) Then
                .Rows.Height = CentimetersToPoints(0.5)
            Else
                .Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 + 0.1)
            End If
        ElseIf .Rows.HeightRule = 9999999 Or .Rows.HeightRule = 0 Then
            .Rows.HeightRule = wdRowHeightAtLeast
            .Rows.Height = CentimetersToPoints(0.5)
        End If
    End With
End Sub
Sub 表格满页()
    CursorIn
    Dim j!, k!, x&, y&
    With Selection
        With .Tables(1).Range
            x = .Characters.First.Information(wdActiveEndPageNumber)
            y = .Characters.Last.Information(wdActiveEndPageNumber)
            If x <> y Then End
            .Rows.Height = CentimetersToPoints(0.5)
            Do
                j = j + 0.02
                .Rows.Height = CentimetersToPoints(0.5 + j)
            Loop Until .Characters.Last.Information(wdActiveEndPageNumber) = y + 1
            j = 0
            Do
                j = j + 0.01
                k = Round(.Rows.Height / 28.35, 2)
                .Rows.Height = CentimetersToPoints(k - j)
            Loop Until .Characters.Last.Information(wdActiveEndPageNumber) = y
        End With
    End With
    最后一磅
End Sub
Sub 表格全选()
    Dim t As Table
    With ActiveDocument
        .DeleteAllEditableRanges wdEditorEveryone
        For Each t In .Tables
            t.Range.Editors.Add wdEditorEveryone
        Next
        .SelectAllEditableRanges wdEditorEveryone
        .DeleteAllEditableRanges wdEditorEveryone
    End With
End Sub
Sub 表格缩行()
    Dim t As Table, c As Cell, a&
    With Selection
        If .Information(12) Then a = 1
        For Each t In ActiveDocument.Tables
            If a = 1 Then Set t = .Tables(1)
            With t.Range.Find
                .Execute "^p", , , , , , , , , "", 2
                .Execute "^l", , , , , , , , , "", 2
                .Execute "^w", , , , , , , , , "", 2
                .Execute " ", , , , , , , , , "", 2
            End With
            For Each c In t.Range.Cells
                c.Range.Select
                .MoveEnd Unit:=wdCharacter, Count:=-1
                With .Font
                    If .Spacing = "9999999" Then .Spacing = 0
                    If .Scaling = "9999999" Then .Scaling = 100
                    If .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) > 1 Then .Spacing = -0.5
                    Do Until .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) = 1
                        If .Parent.Range.ComputeStatistics(statistic:=wdStatisticLines) = 0 Then Exit Do
                        .Scaling = .Scaling - 2
                    Loop
                End With
            Next
            If a = 1 Then Exit For
        Next
        .HomeKey 6
    End With
End Sub
Sub 外框加粗()
    Dim t As Table, i&, j&
    If Selection.Information(12) Then i = 1
    For Each t In ActiveDocument.Tables
        If i = 1 Then Set t = Selection.Tables(1)
        For j = 1 To 4
            t.Range.Borders(-j).LineWidth = 12
        Next
        If i = 1 Then Exit For
    Next
End Sub
Sub 断行相连()
    ActiveDocument.Content.Find.Execute FindText:="([!。:!?…)])^13", MatchWildcards:=True, ReplaceWith:="\1", Replace:=wdReplaceAll
End Sub
Sub CursorIn()
    If Not Selection.Information(12) Then MsgBox "请将光标放在表格中!", 0 + 16: End
End Sub
Sub 删行热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="合并单元格"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="删除行"
    MsgBox "F3:合并单元格    F4:删除行", 0 + 48
End Sub
Sub 合并单元格()
    On Error Resume Next
    With Selection
        .Cells.Merge
        .MoveLeft 1, 1
    End With
End Sub
Sub 删除行()
    CursorIn
    Selection.Rows.Delete
End Sub
Sub 减少行高()
    On Error Resume Next
    CursorIn
    With Selection
        If .Rows.Height / 28.3 <= 0.04 Then End
        If .Type = wdSelectionIP Then .Tables(1).Select
        If .Rows.HeightRule = 1 Or .Rows.HeightRule = 2 Then
            .Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 - 0.05)
        ElseIf .Rows.HeightRule = 9999999 Or .Rows.HeightRule = 0 Then
            .Rows.Height = CentimetersToPoints(0.7)
        End If
    End With
End Sub
Sub 行高热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少行高"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加行高"
    MsgBox "F3:减少行高    F4:增加行高", 0 + 48
End Sub
Sub 减少行高微调()
    CursorIn
    With Selection
        If .Type = wdSelectionIP Then .Tables(1).Select
        .Rows.HeightRule = wdRowHeightAtLeast
        .Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 - 0.01)
        .Rows.HeightRule = wdRowHeightExactly
    End With
End Sub
Sub 行高微调热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少行高微调"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加行高微调"
    MsgBox "F3:减少行高微调    F4:增加行高微调", 0 + 48
End Sub
Sub 行距热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少行距"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加行距"
    MsgBox "F3:减少行距    F4:增加行距", 0 + 48
End Sub
Sub 间距热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少字符间距"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加字符间距"
    MsgBox "F3:减少字符间距    F4:增加字符间距", 0 + 48
End Sub
Sub 缩放热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少字符缩放"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加字符缩放"
    MsgBox "F3:减少字符缩放    F4:增加字符缩放", 0 + 48
End Sub
Sub 悬挂缩进热键()
    ActiveWindow.ActivePane.View.Zoom.Percentage = 100
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="减少悬挂缩进"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="增加悬挂缩进"
    MsgBox "F3:减少悬挂缩进    F4:增加悬挂缩进", 0 + 48
End Sub
Sub 减少悬挂缩进()
    Selection.ParagraphFormat.CharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent + 0.01
End Sub
Sub 增加悬挂缩进()
    Selection.ParagraphFormat.CharacterUnitFirstLineIndent = Selection.ParagraphFormat.CharacterUnitFirstLineIndent - 0.01
End Sub
Sub 第一章()
    Dim i&, j$, k$, m$, n&
    k = MsgBox("<是>:第一章    <否>:第一条    <取消>:自定义", 3 + 48)
    If k = 6 Then
        j = "章"
    ElseIf k = 7 Then
        j = "条"
    Else
        j = InputBox("", "请输入量词(节/课/题/部分/阶段/自然段)", "部分")
        If j = "" Then End
    End If
    m = MsgBox("<是>:第一" & j & "    <否>:第1" & j & "    <取消>:放弃", 3 + 48)
    If m = 6 Then
        n = 2
    ElseIf m = 7 Then
        n = 1
    Else
        End
    End If
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Replacement.Text = ""
            Do While .Execute("^13第[一二三四五六七八九十0-90-9百零〇○Oo千]{1,}" & j, , , 1, , , 1)
                With .Parent
                    If Not .Information(12) Then
                        .MoveStart
                        .Expand 4
                        With .Find
                            .Execute " ", , , , , , , , , "", 2
                            .Execute " ", , , , , , , , , "", 2
                            .Execute "^s", , , , , , , , , "", 2
                            .Execute "^t", , , , , , , , , "", 2
                        End With
                        .Characters(InStr(.Text, j) + Len(j) - 1).InsertAfter Text:=Chr(-24159)
                        If j = "条" Then
                            If .Text Like "*[!。:;,、!?…—.:;,!?]?" Then .Characters.Last.InsertBefore Text:="。"
                            .MoveEnd 1, -(Len(.Text) - InStr(.Text, j))
                            With .Font
                                .NameFarEast = "黑体"
                                .NameAscii = "Times New Roman"
                                .Bold = True
                                .Color = wdColorPink
                            End With
                        Else
                            .Style = wdStyleSubtitle
                            .Font.NameFarEast = "黑体"
                            .Font.Color = wdColorRed
                            If Len(j) > 1 Then .Font.Color = wdColorBrown
                            If Len(j) > 1 Then .Font.Size = 18
                            With .ParagraphFormat
                                .SpaceBefore = 24
                                .SpaceAfter = 30
                            End With
                            If .Text Like "*[。:;,、!?…—.:;,!?]?" Then .Characters.Last.Previous.Delete
                            If .Text Like "* ???" Then .Characters.Last.Previous.InsertBefore Text:=Chr(-24159)
                            .MoveEnd 1, -(Len(.Text) - (InStr(.Text, j) + Len(j) - 1))
                        End If
                        .MoveStart
                        .MoveEnd 1, -Len(j)
                        i = i + 1
                        .Text = i
                        If n = 2 Then
                            .Delete
                            .Fields.Add Range:=.Range, Text:="= " & i & " \* CHINESENUM3"
                            .Paragraphs(1).Range.Fields.Unlink
                        End If
                    Else
                        .Tables(1).Range.Next.Select
                        If Asc(.Text) <> 13 Then .InsertParagraphBefore
                        .Characters(1).Font.Size = 4
                    End If
                    .EndKey 5
                End With
            Loop
        End With
        .HomeKey 6
    End With
End Sub
Sub 千分位()
    Dim i&, j&, k&, h&
    With Selection
        .HomeKey 6
        With .Find
            .ClearFormatting
            .Text = "[0-9.,,  ^s^t]{1,}元"
            .Forward = True
            .MatchWildcards = True
            Do While .Execute
                With .Parent
                    .MoveEnd 1, -1
                    .Text = Replace(.Text, " ", "")
                    .Text = Replace(.Text, " ", "")
                    .Text = Replace(.Text, vbTab, "")
                    .Text = Replace(.Text, ChrW(160), "")
                    .Text = Replace(.Text, ",", "")
                    .Text = Replace(.Text, ",", "")
                    .Text = Format(.Text)
                    If .Text Like "*.*.*" Then .Font.Color = wdColorRed: GoTo skip
                    If .Text Like ".*" Then .Text = "0" & .Text
                    If .Text Like "*?.??" Then
                    ElseIf .Text Like "*?.?" Then
                        .Text = .Text & "0"
                    ElseIf .Text Like "*?.???*" Then
                        .Text = Format(.Text, "0.00")
                    Else
                        .Text = .Text & ".00"
                    End If
                    .Font.Color = wdColorGreen
                    '千分位
                    If .Text Like "*.*" Then i = InStr(.Text, ".") - 1 Else i = Len(.Text)
                    k = Int(i / 3)
                    If k = i / 3 Then k = k - 1
                    If i >= 4 Then
                        For j = 1 To k
                            .Characters(i - 3 * k + h).InsertAfter Text:=","
                            h = h + 4
                        Next j
                        h = 0
                    End If
skip:
                    .Collapse 0
                End With
            Loop
        End With
    End With
End Sub
Sub 清除格式()
'样式(边框/底纹/突出显示/背景)
    With Selection
        .WholeStory
        .ClearFormatting
        .Font.Borders(1).LineStyle = wdLineStyleNone
        .Font.Shading.Texture = wdTextureNone
        .Range.HighlightColorIndex = wdNoHighlight
        ActiveDocument.Background.Fill.Visible = msoFalse
'底纹边框
        With .ParagraphFormat
            .Shading.Texture = wdTextureNone
            .Shading.BackgroundPatternColor = wdColorAutomatic
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderTop).LineStyle = wdLineStyleNone
            .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        End With
'页面边框
        With .Sections(1)
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderTop).LineStyle = wdLineStyleNone
            .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        End With
    End With
End Sub
Sub 删除图文框文本框()
    Dim j As Frame
    For Each j In ActiveDocument.Frames
        j.Delete
    Next
    Dim i As Shape
    For Each i In ActiveDocument.Shapes
        If i.Type = msoTextBox And i.Type = 17 Then
            i.TextFrame.TextRange.Select
            Selection.Copy
            i.Delete
            Selection.Paste
        End If
    Next
    With Selection
        .WholeStory
        With .ParagraphFormat
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Borders(wdBorderTop).LineStyle = wdLineStyleNone
            .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        End With
    End With
End Sub
Sub 删除空行()
    Dim i As Paragraph
    For Each i In ActiveDocument.Paragraphs
        If Asc(i.Range) = 13 Then i.Range.Delete
    Next
End Sub
Sub 姓名加空()
    CursorIn
    Dim r As Range
    With Selection
        If .Type = wdSelectionIP Then .SelectColumn
        Set r = .Range
        With r.Find
            .Execute "<(?)(?)>", , , 1, , , , , , "\1  \2", 2
            .Execute "<(?) (?)>", , , 1, , , , , , "\1  \2", 2
        End With
        .Find.Replacement.Text = ""
    End With
End Sub
Sub 增加行高()
    CursorIn
    With Selection
        If .Type = wdSelectionIP Then .Tables(1).Select
        If .Rows.HeightRule = 1 Or .Rows.HeightRule = 2 Then
            .Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 + 0.05)
        ElseIf .Rows.HeightRule = 9999999 Or .Rows.HeightRule = 0 Then
            .Rows.Height = CentimetersToPoints(0.7)
        End If
    End With
End Sub
Sub 增加行高微调()
    CursorIn
    With Selection
        If .Type = wdSelectionIP Then .Tables(1).Select
        .Rows.HeightRule = wdRowHeightAtLeast
        .Rows.Height = CentimetersToPoints(.Rows.Height / 28.35 + 0.01)
        .Rows.HeightRule = wdRowHeightExactly
    End With
End Sub
Sub 本机排版()
    Dim doc As Document, docNew As Document, docTable As Document, t As Table, y$, s&, i&, j&, g&, x$
    If MsgBox("是否公文排版(否则普通排版)?", 4 + 16) = vbYes Then g = 1 Else g = 0
    Set doc = ActiveDocument
    y = doc.FullName
    If doc.Tables.Count = 0 Then
ct:
        doc.Content.Copy
        doc.Close savechanges:=wdDoNotSaveChanges
        Set docNew = Documents.Add
        docNew.Content.PasteAndFormat Type:=wdFormatPlainText
        If g = 1 Then 核心 Else 外核
        x = Left(y, Len(y) - 4) & "-Old" & ".doc"
        Name y As x
        docNew.SaveAs FileName:=y
        docNew.Characters(1).Copy
        If s = 1 Then GoTo ch
    Else
        i = doc.Tables.Count
        Set docTable = Documents.Add
        Documents(doc).Activate
        For Each t In doc.Tables
            t.Rows.WrapAroundText = False
            t.Range.Copy
            Documents(docTable).Activate
            Selection.Paste
            Selection.TypeText Text:="***" & vbCr
            Documents(doc).Activate
            t.Range.Next(4, 1).InsertBefore Text:="markmytable" & vbCr
            doc.Characters(1).Copy
        Next
        For Each t In doc.Tables
            t.Delete
        Next
        s = 1
        GoTo ct
ch:
        For j = 1 To i
            With Selection
                .HomeKey 6
                With .Find
                    .ClearFormatting
                    .Execute "markmytable", , , 0, , , 1
                End With
                .Delete
                docTable.Tables(j).Range.Copy
                .Paste
                .Paragraphs(1).Range.Font.Size = 4
                docNew.Characters(1).Copy
            End With
        Next j
        Selection.HomeKey 6
        docNew.Save
        docTable.Close savechanges:=wdDoNotSaveChanges
    End If
End Sub
Sub 格式()
    If Documents.Count = 0 Then MsgBox "一词一行/一列表格", 0 + 16, "格式": End
    Dim r As Row
    With ActiveDocument
        With .Content.Find
            .Execute "^13", , , , , , , , , "^p", 2
            .Execute "^11", , , , , , , , , "^p", 2
        End With
        With .Tables
            If .Count = 0 Then
                .Parent.Content.ConvertToTable Separator:=wdSeparateByParagraphs, NumColumns:=1, AutoFitBehavior:=wdAutoFitFixed
            ElseIf .Count = 1 Then
            ElseIf .Count > 1 Then
                MsgBox "一词一行/一列表格", 0 + 16, "格式": End
            End If
        End With
        With .Tables(1)
            .Select
            With Selection
                .ClearFormatting
                .MoveEnd
            End With
            CommandBars.FindControl(ID:=122).Execute
            For Each r In .Rows
                If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
            Next
            .Select
        End With
    End With
End Sub
Sub 标牌()
    格式
    Dim i&, j&, c As Cell, r As Row
    With ActiveDocument
        .PageSetup.Orientation = wdOrientLandscape
        ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
        Selection.InsertColumnsRight
        .Tables(1).AutoFitBehavior (wdAutoFitWindow)
        j = .Tables(1).Rows.Count
        With .Tables(1)
            For i = 1 To j
                .Cell(i, 2).Range.Text = .Cell(i, 1).Range.Text
            Next i
        End With
        .Content.Find.Execute "^p", , , , , , , , , "", 2
        With .Tables(1).Range
            .Style = "普通表格"
            .Rows.HeightRule = wdRowHeightExactly
            .Rows.Height = CentimetersToPoints(14.6)
            .Cells.VerticalAlignment = wdCellAlignVerticalCenter
            With .Font
                .NameFarEast = "黑体"
                .Size = 72
                .Bold = True
            End With
            .Columns(1).Select
            .Orientation = wdTextOrientationDownward
            For Each c In .Columns(2).Cells
                c.Range.Orientation = wdTextOrientationUpward
            Next
        End With
    End With
    最后一磅
    ActiveWindow.View.TableGridlines = True
    Selection.HomeKey 6
End Sub
Sub 标签()
    格式
    With ActiveDocument.PageSetup
        .TopMargin = CentimetersToPoints(2)
        .BottomMargin = CentimetersToPoints(2)
        .LeftMargin = CentimetersToPoints(1)
        .RightMargin = CentimetersToPoints(1)
    End With
    With Selection
        .Tables(1).Style = "网格型"
        .Font.Bold = True
        .Cells.VerticalAlignment = wdCellAlignVerticalCenter
        If MsgBox("<是>:纵向(书脊)    <否>:横向(封面)", 4 + 48) = vbYes Then
            .PageSetup.Orientation = wdOrientLandscape
            .Tables(1).Rows.Alignment = wdAlignRowCenter
            .Rows.Height = CentimetersToPoints(3)
            .Orientation = wdTextOrientationHorizontalRotatedFarEast
            .ParagraphFormat.Alignment = wdAlignParagraphDistribute
            .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
            .Borders(wdBorderRight).LineStyle = wdLineStyleNone
            .Font.Size = 48
        Else
            .Tables(1).AutoFitBehavior (wdAutoFitWindow)
            .PageSetup.TextColumns.SetCount NumColumns:=2
            .Rows.Height = CentimetersToPoints(5)
            .Font.Size = 60
        End If
        ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitFullPage
        ActiveWindow.View.TableGridlines = False
    End With
End Sub
Sub 封面()
    Documents.Add
    With ActiveDocument
        With .Content
            .InsertBefore Text:=vbCr & "方案" & vbCr & "作者" & vbCr & vbCr & "大学" & vbCr & ChrW(160) & Format(Date, "yyyy年m月d日")
            .Font.Bold = True
            With .ParagraphFormat
                .Alignment = wdAlignParagraphCenter
                .AutoAdjustRightIndent = False
                .DisableLineHeightGrid = True
            End With
        End With
        .Paragraphs(1).Range.Font.Size = 110
        .Paragraphs(2).Range.Font.Size = 40
        With .Paragraphs(3).Range
            With .Font
                .Name = "楷体"
                .Size = 22
            End With
            .ParagraphFormat.LineUnitBefore = 1.75
        End With
        .Paragraphs(4).Range.Font.Size = 280
        .Paragraphs(5).Range.Font.Size = 20
        With .Paragraphs(6).Range
            .Font.Size = 18
            .ParagraphFormat.LineUnitBefore = 0.6
        End With
    End With
End Sub
Sub 名单()
    Dim doc As Document, i As Paragraph, j As Range, r As Range, s As Range, b&, c!, n&, m&, x&, y&
    Set doc = ActiveDocument
    With Selection
        If .Type = wdSelectionIP Then MsgBox "请选定<组长/副组长/成员>区域!", 0 + 16, "名单": End
        If Asc(.Previous) = 12 Then .InsertParagraphBefore: .MoveStart 1, 1: x = 1
        If .Paragraphs.Last.Range.End = doc.Content.End Then .InsertParagraphAfter: .MoveEnd 1, -1: y = 1
        .Expand 4
        n = .Characters(1).Font.Size
        Set s = .Range
        .InsertAfter Text:=.Text
        .MoveStart 4, s.Paragraphs.Count
        Set r = .Range
        s.Underline = wdUnderlineWavyHeavy
        With .Find
            .ClearFormatting
            .Execute ":", , , 0, , , , , , ":", 2
            .Execute "(:)[  ^s^t]{1,}", , , 1, , , , , , "\1", 2
            .Execute "。", , , 0, , , , , , "", 2
            .Execute "、", , , 0, , , , , , " ", 2
        End With
        For Each i In r.Paragraphs
            With i.Range
                If .Text Like "*:*" Then
                    .InsertBefore Text:="<"
                        Set j = doc.Range(Start:=.Start, End:=i.Range.Characters(InStr(.Text, ":")).End - 1)
                        With j.Find
                            .Execute " ", , , 0, , , , , , "", 2
                            .Execute " ", , , 0, , , , , , "", 2
                            .Execute "^t", , , 0, , , , , , "", 2
                        End With
                End If
            End With
        Next
        With .Find
            .ClearFormatting
            .Execute "^p", , , 0, , , , , , " ", 2
            .Execute "^s", , , 0, , , , , , " ", 2
            .Execute "^t", , , 0, , , , , , " ", 2
            .Execute " ", , , 0, , , , , , " ", 2
            .Execute ":", , , 0, , , , , , ":^p", 2
            .Execute " ", , , 0, , , , , , "^p", 2
        End With
        For Each i In r.Paragraphs
            If Len(i.Range) = 1 Then i.Range.Delete
        Next
        For Each i In r.Paragraphs
            If Len(i.Range) = 2 Then i.Range.Characters.Last.Delete
        Next
        For Each i In r.Paragraphs
            If Len(i.Range) = 3 Then i.Range.Characters(1).InsertAfter Text:="  "
        Next
        With .Find
            .ClearFormatting
            .Execute ":^p", , , 0, , , , , , ":", 2
            .Execute "^p", , , 0, , , , , , ",", 2
            .Execute ",<", , , 0, , , , , , "^p", 2
        End With
        .ConvertToTable Separator:=wdSeparateByCommas, NumColumns:=5, AutoFitBehavior:=wdAutoFitFixed
        .Rows.ConvertToText Separator:=wdSeparateByTabs, NestedTables:=True
        .Find.Execute "^t", , , 0, , , , , , " ", 2
        正文样式
        .Characters.First.Delete
        r.Select
        For Each i In r.Paragraphs
            If i.Range Like "*:*" Then
                If i.Range Like "????:*" Then
                    b = 7
                ElseIf i.Range Like "???:*" Then
                    b = 6
                Else
                    b = 5
                End If
                If m < b Then m = b
            End If
        Next
        b = m
        If b = 6 Then
            c = 6.1
            For Each i In r.Paragraphs
                If i.Range Like "??:*" Then i.Range.Characters(1).InsertAfter Text:=" "
            Next
        ElseIf b = 7 Then
            c = 7.1
            For Each i In r.Paragraphs
                If i.Range Like "???:*" Then i.Range.Characters(2).InsertAfter Text:=" ": i.Range.Characters(1).InsertAfter Text:=" "
                If i.Range Like "??:*" Then i.Range.Characters(1).InsertAfter Text:="  "
            Next
        ElseIf b = 5 Then
            c = 5.05
        End If
        For Each i In r.Paragraphs
            If Not i.Range Like "*:*" Then i.Range.ParagraphFormat.CharacterUnitFirstLineIndent = c
            i.Range.ParagraphFormat.CharacterUnitRightIndent = -0.5
            If i.Range Like "*:*" Then i.Range.Characters(1).Select: .MoveEndUntil cset:=":": .MoveEnd Unit:=wdCharacter, Count:=1: .Font.Bold = True
        Next
    End With
    With r.Font
        If n = 14 Then .Name = "宋体": .Parent.ParagraphFormat.LineSpacing = LinesToPoints(1.25)
        .Size = n
    End With
    If x = 1 Then s.Previous.Delete
    If y = 1 Then r.Next.Delete
    s.Select
    MsgBox "请对照检查无误后删除原名单(选定区域)!", 0 + 48, "名单"
End Sub
Sub 人民币中文大写()
    Dim i$, j$, k&, n&, m&
    With Selection
        If .Type = wdSelectionIP Then MsgBox "请选定数字!", 0 + 16: End
        If .Text Like "*" & vbCr Then .MoveEnd 1, -1
        .Text = Replace(.Text, " ", "")
        .Text = Replace(.Text, " ", "")
        .Text = Replace(.Text, vbTab, "")
        .Text = Replace(.Text, ChrW(160), "")
        .Text = Replace(.Text, ",", "")
        .Text = Replace(.Text, ",", "")
        Do While .Text Like "[!0-9]*"
            .MoveStart
        Loop
        Do While .Text Like "*[!0-9]"
            .MoveEnd 1, -1
        Loop
        n = Len(Selection)
        .Characters(1).Select
        Do While .Next Like "[0-9.]"
            .MoveEnd
            m = m + 1
            If m = n - 1 Then Exit Do
        Loop
        If .Text Like "*.*" Then
            i = Format(.Text, "0.00")
            j = Right(i, 2)
            i = Left(i, Len(i) - 3)
            k = 1
        Else
            i = .Text
        End If
        If j = "00" Then k = 0
        .TypeText Text:="(人民币"
        .Fields.Add Range:=.Range, Text:="= " & i & " \* CHINESENUM2"
        .TypeText Text:="元"
        If k = 0 Then
            .TypeText Text:="整)"
        Else
            .Fields.Add Range:=.Range, Text:="= " & Left(j, 1) & " \* CHINESENUM2"
            .TypeText Text:="角"
            .Fields.Add Range:=.Range, Text:="= " & Right(j, 1) & " \* CHINESENUM2"
            .TypeText Text:="分)"
        End If
        .Paragraphs(1).Range.Fields.Unlink
        With .Previous.Previous
            If .Previous.Text = "零" Then .Previous.Delete: .Delete
        End With
    End With
End Sub
Sub 自动复制()
    CursorIn
    Dim m&, n&, h&, i$, c As Cell
    With Selection
        m = .Information(wdEndOfRangeRowNumber)
        n = .Information(wdEndOfRangeColumnNumber)
        h = .Information(wdMaximumNumberOfRows)
        .SelectCell
        CommandBars.FindControl(ID:=123).Execute
        CommandBars.FindControl(ID:=122).Execute
        .Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
        If Len(.Text) = 2 Then End
        .MoveEnd 1, -1
        i = .Text
        ActiveDocument.Range(Start:=.Tables(1).Cell(m + 1, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
        .Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
        For Each c In .Cells
            c.Range.Text = i
        Next
        .Tables(1).Cell(m, n).Select
    End With
End Sub
Sub 自动编号()
    CursorIn
    Dim s$, i$, j$, m&, n&, h&, c As Cell, u&, v&, z&, x$, y&
    With Selection
        If .Cells.Count > 1 Then .Cells(1).Select
        m = .Information(wdEndOfRangeRowNumber)
        n = .Information(wdEndOfRangeColumnNumber)
        h = .Information(wdMaximumNumberOfRows)
        .SelectCell
        CommandBars.FindControl(ID:=123).Execute
        CommandBars.FindControl(ID:=122).Execute
        .Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
        If Len(.Text) = 2 Then
            i = 1
            ActiveDocument.Range(Start:=.Tables(1).Cell(m, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
            .Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
            For Each c In .Cells
                c.Range.Text = i
                i = i + 1
            Next
            .Tables(1).Cell(m, n).Select
            End
        End If
        .MoveEnd 1, -1
        .Range.CharacterWidth = wdWidthHalfWidth
        If .Text Like "*[!0-9]" Then MsgBox "非数字!", 0 + 16: End
        j = .Text
        Do While .Text Like "*[0-9]"
            .MoveEnd 1, -1
            If .Type = wdSelectionIP Then Exit Do
        Loop
        If .Type = wdSelectionIP Then
            i = j
            u = 1
        Else
            s = .Text
            i = Right(j, Len(j) - Len(s))
        End If
        v = Len(i)
        If i Like "0*" Then z = 1: i = Format(i)
        If Len(i) > 15 Then MsgBox "编号仅限15位!", 0 + 16: End
        ActiveDocument.Range(Start:=.Tables(1).Cell(m + 1, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
        .Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
        For Each c In .Cells
            i = i + 1
            If Len(i) > v Then Exit For
            If z = 1 Then
                x = ""
                For y = 1 To v - Len(i)
                    x = x & "0"
                Next y
                i = x & i
            End If
            If u = 1 Then
                c.Range.Text = i
            Else
                c.Range.Text = s & i
            End If
        Next
        .Tables(1).Cell(m, n).Select
    End With
End Sub
Sub 证书编号热键()
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF3), KeyCategory:=wdKeyCategoryMacro, Command:="证书行数调整"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF4), KeyCategory:=wdKeyCategoryMacro, Command:="证书编号检查"
    MsgBox "F3:证书行数调整" & vbCr & "F4:证书编号检查", 0 + 48
End Sub
Sub 证书行数调整()
    Dim s As Section, r As Range, a As Range, i&, j&
    For Each s In ActiveDocument.Sections
        If s.Range.Paragraphs.Count = 1 Then Exit For
        Set a = s.Range.Paragraphs(1).Range
        With a.Font
            If .Parent.ComputeStatistics(statistic:=wdStatisticLines) > 1 Then
                .Spacing = -0.5
                Do Until a.ComputeStatistics(statistic:=wdStatisticLines) = 1
                    .Scaling = .Scaling - 2
                Loop
                i = i + 1
            End If
        End With
        Set r = s.Range.Paragraphs(2).Range
        With r.Font
            If .Parent.ComputeStatistics(statistic:=wdStatisticLines) > 2 Then
                .Spacing = -0.5
                Do Until r.ComputeStatistics(statistic:=wdStatisticLines) = 2
                    .Scaling = .Scaling - 2
                Loop
                j = j + 1
            End If
        End With
    Next
    MsgBox "调整 " & i + j & " 处!", 0 + 48, "证书行数调整"
End Sub
Sub 证书编号检查()
    CursorIn
    Dim s$, i$, j$, m&, n&, h&, c As Cell, u&, v&, z&, x$, y&, k$
    With Selection
        .SelectCell
        .MoveEnd 1, -1
        j = .Text
        m = .Information(wdEndOfRangeRowNumber)
        n = .Information(wdEndOfRangeColumnNumber)
        h = .Information(wdMaximumNumberOfRows)
        Do While .Text Like "*[0-9]"
            .MoveEnd 1, -1
            If .Type = wdSelectionIP Then Exit Do
        Loop
        If .Type = wdSelectionIP Then
            i = j
            u = 1
        Else
            s = .Text
            i = Right(j, Len(j) - Len(s))
        End If
        v = Len(i)
        If i Like "0*" Then z = 1: i = Format(i)
        ActiveDocument.Range(Start:=.Tables(1).Cell(m + 1, n).Range.Start, End:=.Tables(1).Cell(h, n).Range.End).Select
        For Each c In .Cells
            i = i + 1
            If Len(i) > v Then Exit For
            If z = 1 Then
                x = ""
                For y = 1 To v - Len(i)
                    x = x & "0"
                Next y
                i = x & i
            End If
            k = Left(c.Range.Text, Len(c.Range.Text) - 2)
            If u = 1 Then
                If k <> i Then
                    c.Select
                    .SplitTable
                    .TypeText Text:="***"
                    c.Select
                    MsgBox "编号不连续!", 0 + 16
                    Exit Sub
                End If
            Else
                If k <> s & i Then
                    c.Select
                    .SplitTable
                    .TypeText Text:="***"
                    c.Select
                    MsgBox "编号不连续!", 0 + 16
                    Exit Sub
                End If
            End If
        Next
        .Tables(1).Cell(m, n).Select
    End With
End Sub
Sub 证书表格合并()
    If ActiveDocument.Saved = False Then MsgBox "未保存!", 0 + 16: End
    Dim doc As Document, d$, a, b, n&, m&, q$, t As Table, c As Cell, r As Row, i&, s$, u$
    Set doc = ActiveDocument

    d = MsgBox("<是>:默认字段        <否>:表格一字段        <取消>:自定义", 3 + 48)
    If d = vbYes Then
        n = 1
        m = 5
        a = Array("证书编号", "课题", "姓名", "单位", "等级")
    ElseIf d = vbNo Then
        n = 2
    Else
        n = 3
        q = InputBox("", "请输入自定义字段(空格分隔)!", "姓名 单位 课题 等级 证书编号")
        If q = "" Then End
        b = Split(q, " ")
        m = UBound(b) + 1
    End If

    证书表格预置

    If n = 2 Then m = doc.Tables(1).Columns.Count

    With doc
        For Each t In .Tables
            With t
                '调整字段
                For i = 1 To m
                    If n = 1 Then
                        s = a(i - 1)
                    ElseIf n = 2 Then
                        s = doc.Tables(1).Rows(1).Cells(i).Range.Text
                        s = Left(s, Len(s) - 2)
                    ElseIf n = 3 Then
                        s = b(i - 1)
                    End If
                    If .Rows(1).Range Like "*" & s & "*" Then
                        .Rows(1).Select
                        With Selection
                            With .Find
                                .ClearFormatting
                                .Execute s
                            End With
                            If .Information(17) <> i Then
                                .Columns(1).Select
                                .Cut
                                t.Columns(i).Select
                                .Paste
                            End If
                        End With
                    Else
                        If i = 1 Then .Cell(1, 1).Select
                        With Selection
                            If i = 1 Then .InsertColumns Else .InsertColumnsRight
                            .Cells(1).Range.Text = s
                        End With
                    End If
                Next i

                '删除末列
                If n = 1 Then
                    u = "等级"
                ElseIf n = 2 Then
                    u = doc.Tables(1).Rows(1).Cells(doc.Tables(1).Columns.Count).Range.Text
                    u = Left(u, Len(u) - 2)
                ElseIf n = 3 Then
                    u = b(UBound(b))
                End If
                Do While Not .Rows(1).Cells(.Columns.Count).Range Like u & "*"
                    .Columns(.Columns.Count).Delete
                Loop
            End With
        Next

        '合并数据
        Do While .Tables.Count > 1
            With .Tables(2)
                .Rows(1).Delete
                .Select
            End With
            With Selection
                .MoveEnd 1, -1
                .Cut
            End With
            .Tables(1).Range.Characters.Last.Select
            With Selection
                .MoveRight 12, 1
                .Paste
            End With
            .Characters(1).Copy
        Loop
    End With

    证书表格后期

End Sub
Sub 证书表格预置()
    Dim t As Table, c As Cell, r As Row, x&, y&, z&, j&, k&, e&
    With ActiveDocument
        With .Content.Find
            .Execute "^13", , , , , , , , , "", 2
            .Execute "^11", , , , , , , , , "", 2
        End With

        For Each t In .Tables
            With t
                '取消环绕
                With .Rows
                    .WrapAroundText = False
                    .Alignment = wdAlignRowLeft
                    .LeftIndent = CentimetersToPoints(0)
                End With

                '是否规则(e=1=规则/e=0=不规则)
                With .Range
                    x = .Information(wdEndOfRangeRowNumber)
                    y = .Information(wdEndOfRangeColumnNumber)
                    z = .Cells.Count
                End With
                If x <> 1 Then
                    If z = x * y Then
                        For k = 1 To y
                            For j = 1 To x - 1
                                If .Cell(j + 1, k).Width = .Cell(j, k).Width Then e = 1 Else e = 0
                                If e = 0 Then Exit For
                            Next j
                            If e = 0 Then Exit For
                        Next k
                    Else
                        e = 0
                    End If
                Else
                    e = 1
                End If
                If e = 0 Then .Select: MsgBox "表格不规则!", 0 + 16: End
            End With
        Next

        For Each t In .Tables
            With t
                '删除空格
                .Select
                Selection.MoveEnd
                CommandBars.FindControl(ID:=122).Execute

                '删除表头空格
                With .Rows(1).Range.Find
                    .Execute "^w", , , , , , , , , "", 2
                    .Execute " ", , , , , , , , , "", 2
                End With

                '规范字段
                For Each c In .Rows(1).Cells
                    With c.Range
                        If .Text Like "*序号*" Then
                            .Text = "序号"
                        ElseIf .Text Like "*姓名*" Then
                            .Text = "姓名"
                        ElseIf .Text Like "*课题*" Then
                            .Text = "课题"
                        ElseIf .Text Like "*[单学][位校]*" Then
                            .Text = "单位"
                        ElseIf .Text Like "*[等奖][级项]*" Then
                            .Text = "等级"
                        ElseIf .Text Like "*编号*" Then
                            .Text = "证书编号"
                        End If
                        If Len(.Text) = 2 Then .Text = "空列"
                    End With
                Next

                '删除空列
                Do While .Rows(1).Range Like "*空列*"
                    .Rows(1).Select
                    With Selection
                        With .Find
                            .ClearFormatting
                            .Execute "空列"
                        End With
                        .Columns.Delete
                    End With
                Loop

                '删除序号
                .Rows(1).Select
                With Selection.Find
                    .ClearFormatting
                    .Execute "序号"
                    If .Found = True Then .Parent.Columns.Delete
                End With

                '删除空行
                For Each r In .Rows
                    If Len(Replace(Replace(r.Range, vbCr, ""), Chr(7), "")) = 0 Then r.Delete
                Next

                '蓝色粉红
                .Range.Font.Color = wdColorBlue
                .Rows(2).Range.Font.Color = wdColorPink
            End With
        Next
    End With
End Sub
Sub 证书表格后期()
    With ActiveDocument
        If Not .Paragraphs(1).Range.Information(12) Then .Paragraphs(1).Range.Delete
        .Range(Start:=.Tables(1).Range.End, End:=.Content.End).Delete
        With .Tables(1).Rows(1).Range.Font
            .Color = wdColorRed
            .Bold = True
        End With
        With .Tables(1)
            With .Range
                .Font.Size = 10.5
                .ParagraphFormat.Space1
            End With
            With .Rows
                .HeightRule = wdRowHeightAtLeast
                .Height = CentimetersToPoints(0)
            End With
            .Select
            .AutoFitBehavior (wdAutoFitContent)
            .Select
            .AutoFitBehavior (wdAutoFitWindow)
        End With
        ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
        Selection.HomeKey 6
    End With
End Sub
Sub 证书自动编号()
    If ActiveDocument.Tables.Count <> 1 Then MsgBox "证书数据源仅限一个表格!", 0 + 16: End
    Dim doc As Document, t As Table, c As Cell, m&, n&, x&, k&, d&, b&
    Set doc = ActiveDocument
    Set t = doc.Tables(1)

    证书表格预置

'字段
    With t
        For Each c In .Rows(1).Cells
            With c.Range
                If .Text Like "姓名*" Then
                    x = .Information(17)
                ElseIf .Text Like "课题*" Then
                    k = .Information(17)
                ElseIf .Text Like "等级*" Then
                    d = .Information(17)
                ElseIf .Text Like "证书编号*" Then
                    b = .Information(17)
                End If
            End With
        Next
        If x = 0 Or k = 0 Then MsgBox "<姓名/课题>丢失!", 0 + 16: End
        If d = 0 Then If MsgBox("<等级>丢失!是否继续?", 4 + 16) = vbNo Then End
        If b = 0 Then If MsgBox("<证书编号>丢失!是否继续?", 4 + 16) = vbNo Then End

'编号
        If b > 0 Then .Cell(2, b).Range.Select: 自动编号
        m = .Rows.Count

'等级
        If d > 0 Then
            doc.Range(Start:=.Cell(2, d).Range.Start, End:=.Cell(m, d).Range.End).Select
            For Each c In Selection.Cells
                With c.Range
                    If Len(.Text) = 2 Then
                        .Shading.BackgroundPatternColor = wdColorRed
                    ElseIf .Text Like "[11一壹]*" Then
                        .Text = "一等"
                    ElseIf .Text Like "[22二贰]*" Then
                        .Text = "二等"
                    ElseIf .Text Like "[33三叁]*" Then
                        .Text = "三等"
                    End If
                End With
            Next
        End If

'姓名
        .Columns(x).Select
        Selection.Find.Execute "[  ^s]@", , , 1, , , , , , "", 2
        doc.Range(Start:=.Cell(2, x).Range.Start, End:=.Cell(m, x).Range.End).Select
        For Each c In Selection.Cells
            With c.Range
                .MoveEnd 1, -1
                If Len(.Text) = 0 Then
                    .Shading.BackgroundPatternColor = wdColorRed
                ElseIf Len(.Text) = 1 Then
                    .Shading.BackgroundPatternColor = wdColorBrightGreen
                ElseIf Len(.Text) = 2 Then
                    .Characters(1).InsertAfter Text:="  "
                ElseIf Len(.Text) >= 4 Then
                    .Shading.BackgroundPatternColor = wdColorBrightGreen
                End If
            End With
        Next

'课题
        .Columns(k).Select
        With Selection.Find
            .ClearFormatting
            .Execute "《", , , , , , , , , "〈", 2
            .Parent.SelectColumn
            .Execute "》", , , , , , , , , "〉", 2
        End With
        doc.Range(Start:=.Cell(2, k).Range.Start, End:=.Cell(m, k).Range.End).Select
        For Each c In Selection.Cells
            With c.Range
                .MoveEnd 1, -1
                If Len(.Text) = 0 Then
                    .Shading.BackgroundPatternColor = wdColorRed
                ElseIf .Text Like "〈*〉" Then
                    .Characters.First.Delete
                    .Characters.Last.Delete
                ElseIf .Text Like "〈*" Then
                    If Not (.Text Like "〈*〉?*") Then .Characters.First.Delete
                ElseIf .Text Like "*〉" Then
                    If Not (.Text Like "*?〈*〉") Then .Characters.Last.Delete
                ElseIf .Text Like "*?〈?*" Then
                    If Not (.Text Like "*〈*〉*") Then .Text = .Text & "〉"
                ElseIf .Text Like "*?〉?*" Then
                    .Text = "〈" & .Text
                End If
            End With
        Next

'序号
        .Columns(1).Select
        With Selection
            .InsertColumns
            .Shading.BackgroundPatternColor = wdColorAutomatic
            .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
            For Each c In .Cells
                c.Range.Text = n
                n = n + 1
            Next
            .Cells(1).Range.Text = "序号"
        End With

        证书表格后期

'校验
        If b > 0 Then .Cell(2, b + 1).Select: 证书编号检查: 证书编号热键
    End With
End Sub
Sub doc2txt()
    Dim i$, j$
    With ActiveDocument
        i = .FullName
        If Not i Like "*:*" Then MsgBox "未保存!不能转换!", 0 + 16: End
        If i Like "*.doc" Or i Like "*.txt" Then
            j = Left(i, Len(i) - 4)
        ElseIf i Like "*.docx" Then
            j = Left(i, Len(i) - 5)
        End If
        If i Like "*.doc" Or i Like "*.docx" Then
            .SaveAs FileName:=j, FileFormat:=wdFormatText
        ElseIf i Like "*.txt" Then
            .SaveAs FileName:=j, FileFormat:=wdFormatDocument
        Else
            End
        End If
        .Close
    End With
    If MsgBox("转换完毕!是否删除源文件?", 4 + 64, "doc2txt & txt2doc") = vbYes Then Kill i
End Sub
Sub 批量排版()
    On Error Resume Next
    Dim fd As FileDialog, i&, doc As Document, p$, e&, g&
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("是否排版文件夹 " & p & " ?", 4 + 48) = vbNo Then Exit Sub
    If MsgBox("<是>:Word文档(*.doc)    <否>:提取文件名", 4 + 48) = vbYes Then e = 1 Else e = 0
    If e = 1 Then
        If MsgBox("<是>:公文排版    <否>:普通排版", 4 + 16) = vbYes Then g = 1 Else g = 0
    Else
        Documents.Add
    End If
    With Application.FileSearch
        .NewSearch
        .LookIn = p
        .SearchSubFolders = True
        .FileName = "*.doc"
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                If e = 1 Then
                    Set doc = Documents.Open(FileName:=.FoundFiles(i))
                    If g = 1 Then 核心 Else 外核
                    删除页眉横线
                    ActiveWindow.ActivePane.View.Zoom.PageFit = wdPageFitBestFit
                    doc.Close savechanges:=wdSaveChanges
                Else
                    ActiveDocument.Content.InsertAfter Text:=.FoundFiles(i) & vbCr
                End If
            Next i
            MsgBox "排版完毕!共排版 " & .FoundFiles.Count & " 个文件!", 0 + 48
        Else
            MsgBox "未发现文件!", 0 + 16
        End If
    End With
End Sub
Sub 批量打印()
    On Error Resume Next
    Dim fd As FileDialog, i&, doc As Document, p$, s As Section, j&, k$, x&, t&
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("是否打印文件夹 " & p & " ?", 4 + 48) = vbNo Then Exit Sub
    k = InputBox("请输入打印份数!", "批量打印", "1")
    If k = "" Then Exit Sub
    For t = 1 To k
        With Application.FileSearch
            .NewSearch
            .LookIn = p
            .SearchSubFolders = True
            .FileName = "*.doc"
            If .Execute > 0 Then
                For i = 1 To .FoundFiles.Count
                    Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
                    For Each s In doc.Sections
                        With s.PageSetup
                            If .Orientation = wdOrientLandscape Then j = 1 Else j = 0
                            If .PaperSize <> wdPaperA4 Then .PaperSize = wdPaperA4: If j = 1 Then .Orientation = wdOrientLandscape
                        End With
                    Next
                    doc.PrintOut
                    doc.Close savechanges:=wdDoNotSaveChanges
                Next i
                x = .FoundFiles.Count
            Else
                MsgBox "未发现文件!", 0 + 16: End
            End If
        End With
        Dialogs(wdDialogNewToolbar).Display timeout:=1 '延时
    Next t
    MsgBox "打印完毕!共打印 " & x & " 个文件!" & k & " 份!", 0 + 48
End Sub
Sub 批量合并()
    On Error Resume Next
    Dim fd As FileDialog, i&, doc As Document, p$, t&, j&, s As Section, k&, n&, m&, c&
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("是否合并文件夹 " & p & " ?", 4 + 48) = vbNo Then End
    If MsgBox("<是>:Word 文档(*.doc)    <否>:文本文档(*.txt)", 4 + 48) = vbYes Then t = 0 Else t = 1
    If MsgBox("请选择分隔符!——<是>:分节符    <否>:分页符", 4 + 48) = vbYes Then j = 1 Else j = 0
    If j = 1 Then
        If MsgBox("每节页码!——<是>:重排    <否>:顺延", 4 + 48) = vbYes Then k = 1 Else k = 2
    Else
        k = 2
    End If
    Documents.Add
    With Application.FileSearch
        .NewSearch
        .LookIn = p
        .SearchSubFolders = True
        If t = 0 Then .FileName = "*.doc" Else .FileName = "*.txt"
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                If t = 0 Then
                    Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
                Else
                    Set doc = Documents.Open(FileName:=.FoundFiles(i), Encoding:=936, Visible:=False)
                End If
                doc.Content.Copy
                doc.Close
                Selection.EndKey 6
                Selection.Paste
                ActiveDocument.Characters(1).Copy
                If j = 1 Then
                    Selection.InsertBreak Type:=wdSectionBreakNextPage
                Else
                    Selection.InsertBreak Type:=wdPageBreak
                End If
            Next i
            MsgBox "合并完毕!共合并 " & .FoundFiles.Count & " 个文件!", 0 + 64
        Else
            MsgBox "未发现文件!", 0 + 16
        End If
    End With
    With ActiveDocument
        .Characters.Last.Previous.Delete
        .Characters.Last.Previous.Delete
'重排页码
        For Each s In .Sections
            s.Range.Select
            删除页眉横线
            s.Footers(wdHeaderFooterPrimary).Range.Delete
            With Selection.Sections(1).Headers(1).PageNumbers
                .NumberStyle = wdPageNumberStyleNumberInDash
                If k = 1 Then .RestartNumberingAtSection = True Else .RestartNumberingAtSection = False
                .StartingNumber = 1
            End With
            Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:=wdAlignPageNumberCenter, FirstPage:=True
            ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
            Selection.HeaderFooter.LinkToPrevious = Not Selection.HeaderFooter.LinkToPrevious
            ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
        Next
        Selection.HomeKey 6
'奇数加页
        Do
            For Each s In .Sections
                n = s.Range.Information(3)
                n = n - m
                m = m + n
                If n Mod 2 = 1 Then
                    s.Range.Characters.Last.InsertBreak Type:=wdPageBreak
                    n = 0
                    m = 0
                    c = 1
                    Exit For
                Else
                    c = 0
                End If
            Next
        Loop Until c = 0
    End With
End Sub
Sub 批量转换doc2txt()
    If MsgBox("请将<AutoOpen>宏改名避免麻烦!是否继续?", 4 + 16) = vbNo Then End
    On Error Resume Next
    Dim fd As FileDialog, i&, j$, doc As Document, p$, t&
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    If fd.Show = -1 Then p = fd.SelectedItems(1) Else Exit Sub
    Set fd = Nothing
    If MsgBox("是否转换文件夹 " & p & " ?", 4 + 48) = vbNo Then End
    j = MsgBox("<是>:doc2txt    <否>:txt2doc    <取消>:docx2doc", 3 + 48)
    If j = vbYes Then
        t = 1
    ElseIf j = vbNo Then
        t = 2
    Else
        t = 3
    End If
    With Application.FileSearch
        .NewSearch
        .LookIn = p
        .SearchSubFolders = True
        If t = 1 Then
            .FileName = "*.doc"
        ElseIf t = 2 Then
            .FileName = "*.txt"
        Else
            .FileName = "*.docx"
        End If
        If .Execute > 0 Then
            For i = 1 To .FoundFiles.Count
                If t = 1 Then
                    Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
                    doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 4) & ".txt", FileFormat:=wdFormatText
                ElseIf t = 2 Then
                    Set doc = Documents.Open(FileName:=.FoundFiles(i), ConfirmConversions:=False, Visible:=False)
                    doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 4), FileFormat:=wdFormatDocument
                Else
                    Set doc = Documents.Open(FileName:=.FoundFiles(i), Visible:=False)
                    doc.SaveAs FileName:=Left(doc.FullName, Len(doc.FullName) - 5), FileFormat:=wdFormatDocument
                End If
                ActiveDocument.Close
            Next i
            MsgBox "转换完毕!共转换 " & .FoundFiles.Count & " 个文件!", 0 + 64
        Else
            MsgBox "未发现文件!", 0 + 16
        End If
    End With
End Sub
Sub 删除当前文档()
    Dim i$, j$
    With ActiveDocument
        i = .FullName
        If Not i Like "*:*" Then MsgBox "无法删除新建文档!", 0 + 16: End
        j = InputBox("请输入 killfile(按确定/回车)删除!", "删除当前文档(不可恢复)", "")
        If j = "killfile" Then
            .Close savechanges:=wdDoNotSaveChanges
            Kill i
        End If
    End With
End Sub
Sub aaaa自定义()
'热键
    If Documents.Count = 0 Then Documents.Add
    CustomizationContext = NormalTemplate
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF12, wdKeyAlt), KeyCategory:=wdKeyCategoryMacro, Command:="ToolsRecordMacroToggle"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF5), KeyCategory:=wdKeyCategoryMacro, Command:="FileSave"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF6), KeyCategory:=wdKeyCategoryMacro, Command:="FileClose"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF7), KeyCategory:=wdKeyCategoryMacro, Command:="普通"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF8), KeyCategory:=wdKeyCategoryMacro, Command:="公文"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF9), KeyCategory:=wdKeyCategoryMacro, Command:="打印关闭不保存"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF10), KeyCategory:=wdKeyCategoryMacro, Command:="打印N份关闭不保存"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF11), KeyCategory:=wdKeyCategoryMacro, Command:="打印当前页"
    KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF2), KeyCategory:=wdKeyCategoryMacro, Command:="减少首行缩进"

'常用
    Dim i&, arr
    CommandBars("Standard").Reset

    With CommandBars("Standard").Controls
        .Add Type:=msoControlButton, ID:=26
        .Add(Type:=msoControlButton, ID:=2201).FaceId = 476 '大/小写
        .Add(Type:=msoControlButton, ID:=2793).FaceId = 252 '全/半角
        arr = Array("宋体", "宋", "仿宋", "仿", "楷体", "楷", "黑体", "黑", "Times New Roman", "英")
        For i = 0 To UBound(arr) Step 2
            .Add(Type:=msoControlButton, ID:=2823, Parameter:=arr(i)).Caption = arr(i + 1)
        Next i

        arr = Array(4, 141, 7391, 247, 3462, 809)
        For i = 0 To UBound(arr)
            .Add Type:=msoControlButton, ID:=arr(i)
        Next i

        With .Add(Type:=msoControlPopup)
            .BeginGroup = True
            .Caption = "辅助"
        End With
    End With
'
    With CommandBars("Standard").Controls("辅助").Controls
        arr = Array("证书自动编号", "证书编号热键", "证书表格合并", "悬挂缩进热键", "行距热键", "间距热键", "缩放热键", "删行热键")
        For i = 0 To UBound(arr)
            With .Add(Type:=msoControlButton)
                .Caption = arr(i)
                .OnAction = arr(i)
            End With
        Next i

        With .Add(Type:=msoControlButton)
            .BeginGroup = True
            .Caption = "默认纸张A4(2.54/3.17)"
            .FaceId = 18
            .OnAction = "PaperSetup"
        End With

        With .Add(Type:=msoControlButton)
            .Caption = "删除当前文档"
            .FaceId = 478
            .OnAction = "删除当前文档"
        End With

        With .Add(Type:=msoControlButton)
            .Caption = "标题自动编号"
            .FaceId = 71
            .OnAction = "Title2345AutoNum"
        End With

        arr = Array("本机排版", "发文字号", "清除格式", "标牌", "标签", "封面", "名单", "第一章", "千分位", "人民币中文大写", "m2m3上标", "断行相连", "姓名加空", "最后一磅", "删除空行", "删除图文框文本框", "doc2txt", "批量转换doc2txt", "批量排版", "批量打印", "批量合并")
        For i = 0 To UBound(arr)
            With .Add(Type:=msoControlButton)
                .Caption = arr(i)
                .OnAction = arr(i)
            End With
        Next i
    End With

    With CommandBars("Standard").Controls
        With .Add(Type:=msoControlButton)
            .BeginGroup = True
            .Caption = "粘贴无格式文本"
            .FaceId = 1100
            .OnAction = "粘贴无格式文本"
        End With

        arr = Array("删除所有空格", 456, "切换页码", 127, "切换页眉", 762, "表格处理", 203, "切换标题副标题", 251, "取消网格", 217, "纵横转换", 1545, "另存为", 270, "关闭不保存", 1716, "重新打开", 688)
        For i = 0 To UBound(arr) Step 2
            With .Add(Type:=msoControlButton)
                .Caption = arr(i)
                .FaceId = arr(i + 1)
                .OnAction = arr(i)
            End With
        Next i
    End With

    CommandBars("Formatting").Reset

    With CommandBars("Formatting").Controls
        arr = Array(62, 63, 57, 58)
        For i = 0 To UBound(arr)
            .Add Type:=msoControlButton, ID:=arr(i)
        Next i

'"增加段前间距", 597
        arr = Array("普通", 329, "公文", 417, "取消标题", 487, "缩减一行", 1060, "减少字符缩放", 163, "标准字符缩放", 158, "减少字符间距", 1355, "增加字符间距", 1353)
        For i = 0 To UBound(arr) Step 2
            With .Add(Type:=msoControlButton)
                .Caption = arr(i)
                .FaceId = arr(i + 1)
                .OnAction = arr(i)
            End With
        Next i

        .Add(Type:=msoControlButton, ID:=2226).FaceId = 219 '标准

        arr = Array("减少一页", 173, "减少行距", 227, "增加行距", 692)
        For i = 0 To UBound(arr) Step 2
            With CommandBars("Formatting").Controls.Add(Type:=msoControlButton)
                .Caption = arr(i)
                .FaceId = arr(i + 1)
                .OnAction = arr(i)
            End With
        Next i

        .Add Type:=msoControlButton, ID:=699
        .Add Type:=msoControlButton, ID:=698

        With .Add(Type:=msoControlButton, ID:=756) '全选
            .BeginGroup = True
            .Caption = "全选"
            .Style = msoButtonCaption
        End With

        arr = Array(54, 55, 56)
        For i = 0 To UBound(arr)
            .Add Type:=msoControlButton, ID:=arr(i)
        Next i

        .Add(Type:=msoControlButton, ID:=178).Style = msoButtonIcon '全屏
        .Add Type:=msoControlButton, ID:=6 '页宽
        .Add Type:=msoControlButton, ID:=5 '单页
        CommandBars("Print Preview").Controls(4).Copy Bar:=CommandBars("Formatting") '多页
    End With

'表格
    CommandBars("Tables and Borders").Reset

    With CommandBars("Tables and Borders").Controls
        arr = Array(3918, 3681, 3683, 293, 3685, 3687, 294, 3907, 3908)
        For i = 0 To UBound(arr)
            .Add Type:=msoControlButton, ID:=arr(i)
        Next i

        arr = Array(803, "选定表格", 59, 3704, "表格属性", 276, 805, "标题行重复", 502, 808, "拆分表格", 531)
        For i = 0 To UBound(arr) Step 3
            With .Add(Type:=msoControlButton, ID:=arr(i))
                .Caption = arr(i + 1)
                .FaceId = arr(i + 2)
                .Style = msoButtonIconAndCaption
            End With
        Next i

        .Add(Type:=msoControlButton, ID:=332).FaceId = 1977

        arr = Array("行高热键", 541, "行高微调热键", 3100, "自动复制", 703, "自动编号", 1095, "表格满页", 372, "表格缩行", 371, "行高循环", 3526, "外框加粗", 1705, "表格全选", 165)
        For i = 0 To UBound(arr) Step 2
            With .Add(Type:=msoControlButton)
                .Caption = arr(i)
                .FaceId = arr(i + 1)
                .OnAction = arr(i)
            End With
        Next i
    End With

'全屏
    CommandBars("Full Screen").Reset
    CommandBars("Full Screen").Controls.Add Type:=msoControlButton, ID:=6 '页宽
    CommandBars("Full Screen").Controls.Add Type:=msoControlButton, ID:=5 '单页
    CommandBars("Print Preview").Controls(4).Copy Bar:=CommandBars("Full Screen") '多页
End Sub
 

  • 0
    点赞
  • 3
    收藏
    觉得还不错? 一键收藏
  • 0
    评论
以下是使用VBA代码将Excel中的数据填入Word模板中的基本步骤: 1. 打开Word模板文件并创建Word文档对象。 ```VBA Dim wordApp As Word.Application Dim wordDoc As Word.Document Set wordApp = New Word.Application Set wordDoc = wordApp.Documents.Open("C:\Template.docx") ``` 2. 在Word模板中插入书签并保存。 在Word模板中插入书签,书签将用于标识我们要填充数据的位置。例如,我们可以在Word模板中插入名为"Name"和"Age"的两个书签。 ```VBA wordDoc.Bookmarks.Add "Name", wordDoc.Range(0, 0) wordDoc.Bookmarks.Add "Age", wordDoc.Range(0, 0) wordDoc.Save ``` 3. 打开Excel文件并读取数据。 ```VBA Dim excelApp As Excel.Application Dim excelWorkbook As Excel.Workbook Dim excelWorksheet As Excel.Worksheet Set excelApp = New Excel.Application Set excelWorkbook = excelApp.Workbooks.Open("C:\Data.xlsx") Set excelWorksheet = excelWorkbook.Worksheets("Sheet1") Dim name As String Dim age As Integer name = excelWorksheet.Range("A2").Value age = excelWorksheet.Range("B2").Value excelWorkbook.Close ``` 4. 在Word文档中填充数据。 ```VBA wordDoc.Bookmarks("Name").Range.Text = name wordDoc.Bookmarks("Age").Range.Text = age ``` 5. 关闭Word文档和Excel应用程序并保存Word文档。 ```VBA wordDoc.Close SaveChanges:=True wordApp.Quit excelApp.Quit ``` 完整的VBA代码如下: ```VBA Sub FillWordTemplate() Dim wordApp As Word.Application Dim wordDoc As Word.Document Dim excelApp As Excel.Application Dim excelWorkbook As Excel.Workbook Dim excelWorksheet As Excel.Worksheet '打开Word模板文件 Set wordApp = New Word.Application Set wordDoc = wordApp.Documents.Open("C:\Template.docx") '在Word模板中插入书签并保存 wordDoc.Bookmarks.Add "Name", wordDoc.Range(0, 0) wordDoc.Bookmarks.Add "Age", wordDoc.Range(0, 0) wordDoc.Save '打开Excel文件并读取数据 Set excelApp = New Excel.Application Set excelWorkbook = excelApp.Workbooks.Open("C:\Data.xlsx") Set excelWorksheet = excelWorkbook.Worksheets("Sheet1") Dim name As String Dim age As Integer name = excelWorksheet.Range("A2").Value age = excelWorksheet.Range("B2").Value excelWorkbook.Close '在Word文档中填充数据 wordDoc.Bookmarks("Name").Range.Text = name wordDoc.Bookmarks("Age").Range.Text = age '关闭Word文档和Excel应用程序并保存Word文档 wordDoc.Close SaveChanges:=True wordApp.Quit excelApp.Quit End Sub ``` 以上代码仅供参考,具体实现可能需要根据具体情况进行调整。

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值