杜先生请进：公文中文标题四个层次自动设置（宏）

413191246se

    非常感谢 杜先生！
    既然 杜先生 给面子，已经接手此宏，那就请 杜先生 负责到底了！请看下面《公文中文标题四个层次》文本示例，请用 杜先生 擅长、拿手的《正则表达式》代码及 WORD VBA 代码，编写一个综合设置此四个层次标题的宏：（假设文档中有表格，但不处理表格中的标题层次，把相应段落设置为 .style=wdheading2/3/4/5即可）
***************
九千八百七十六、指导思想（设置为《标题2》样式）
（五千四百三十二）规范学校领导干部管理（设置《标题3》样式）
9876、加强师德师风建设（设置为《标题4》样式，有时是：1.XX，有时还是1．XX齐线墨点）
（5342）落实纪检监察工作责任制。（设置为《标题5》样式）

413191246se

请 杜先生 保重身体，赶快休息，明天再处理此帖。杜先生 的代码，令我 叹为观止，望洋兴叹！太妙了！杜先生，补充一下：文档分纯文字无表格 和 文字加表格 两种情况来设置标题2345。

duquancai

纯文本和有表格通用（不处理表格中的标题层次），没有图片、图形、域等
同时也把 段首空白去掉吧！！！！

Sub 四种标题层次设置()
'    纯文本和有表格通用（不处理表格中的标题层次），没有图片、图形、域等，请自行清除段首空格！！！
    Dim mt, reg As Object, n&, m&, L&
    ActiveDocument.Content.Find.Execute "^11", , , 1, , , , , , "^p", 2
    ActiveDocument.Content.Find.Execute "^p^w", , , 0, , , , , , "^p", 2
    ostr$ = Replace(ActiveDocument.Content, Chr(7), "")
    sr$ = "〇一二三四五六七八九十百千万亿"
    r1$ = "^[" & sr & "]+、": r2$ = "^[(（]\s*[" & sr & "]+\s*[)）]"
    r3$ = "^\d+[、.．]": r4$ = "^[(（]\s*\d+\s*[)）]"
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    reg.Pattern = "" & r2 & "|" & r1 & "|" & r4 & "|" & r3 & ""
    For Each mt In reg.Execute(ostr)
        m = mt.FirstIndex: n = mt.Length
        With ActiveDocument.Range(m, m + n)
            If Not .Information(wdWithInTable) Then
                .Expand 4: L = Len(.Text): .Collapse
                If .MoveWhile(sr, L) > 0 Then
                    .Expand 4
                    .Style = ActiveDocument.Styles("标题 2")
                    .Font.ColorIndex = 6
                ElseIf .MoveWhile("(（", L) > 0 Then
                    If .MoveWhile(sr, L) > 0 Then
                        .Expand 4
                        .Style = ActiveDocument.Styles("标题 3")
                        .Font.ColorIndex = 5
                    Else
                        .Expand 4
                        .Style = ActiveDocument.Styles("标题 5")
                        .Font.ColorIndex = 11
                    End If
                Else
                    .Expand 4
                    .Style = ActiveDocument.Styles("标题 4")
                    .Font.ColorIndex = 2
                End If
            End If
        End With
    Next
End Sub

小花鹿

duquancai 发表于 2017-5-16 09:30
纯文本和有表格通用（不处理表格中的标题层次），没有图片、图形、域等
同时也把 段首空白去掉吧！！！！ ...

不用正则，查找替换应该可以吧

duquancai

小花鹿 发表于 2017-5-16 11:23
不用正则，查找替换应该可以吧

Sub 四种标题层次设置()
    Dim a, b, c, doc As Document, j&
    Set doc = ActiveDocument
    doc.Content.Find.Execute "^11", , , 1, , , , , , "^p", 2
    doc.Content.Find.Execute "^p^w", , , 0, , , , , , "^p", 2
    sr$ = "〇一二三四五六七八九十百千万亿"
    r1$ = "^13[" & sr & "]@、": r2$ = "^13[(（][" & sr & "]@[)）]"
    r3$ = "^13[0-9]@[、.．]": r4$ = "^13[(（][0-9]@[)）]"
    a = Array(r1, r2, r3, r4): b = Array(6, 5, 2, 11)
    c = Array("标题 2", "标题 3", "标题 4", "标题 5")
    For j = 0 To UBound(a)
        With doc.Content.Find
            Do While .Execute(a(j), , , 1)
                With .Parent
                    If Not .Information(wdWithInTable) Then
                        .Start = .Start + 1: .Style = doc.Styles("" & c(j) & "")
                        .Expand 4: .Font.ColorIndex = b(j)
                        .Collapse
                    End If
                End With
            Loop
        End With
    Next
End Sub

duquancai

5楼这有点小BUG   呵呵，有空的的时候把这个BUG给修理了。

413191246se

杜先生 辛苦了！太感谢了！
——经我测试，3楼代码，完全OK！ 5楼代码，有个小BUG，即表格下面一段未设置。
——另外，经我用别人写的VBA运行时间宏测试，
3楼代码用时分别为：.15625秒，.15625秒，.1445秒
5楼代码用时分别为：.2695秒，.2695秒，.2695秒
——3楼代码取胜！杜先生 不必优化了，我再细细设置一下各个标题即可.
——我刚才也做了一下《只排版文字不排版表格的公文宏》，尚未完善。
——请 杜先生 好好休息，万分感谢！（但请关注此帖，可能还有问题请教。）

duquancai

413191246se 发表于 2017-5-16 16:20
杜先生 辛苦了！太感谢了！
——经我测试，3楼代码，完全OK！ 5楼代码，有个小BUG，即表格下面一段未设置 ...

比正则效率要低，但是不受文档内容的限制，同时修复了5楼代码的BUG

Sub 四种标题层次设置_不受内容的限制()
    Dim a, b, c, doc As Document, j&, ksr$, x&
    Set doc = ActiveDocument
    doc.Content.Find.Execute "^11", , , 1, , , , , , "^p", 2
    doc.Content.Find.Execute "^p^w", , , 0, , , , , , "^p", 2
    sr$ = "〇一二三四五六七八九十百千万亿"
    r1$ = "[" & sr & "]@、": r2$ = "[(（][" & sr & "]@[)）]"
    r3$ = "[0-9]@[、.．]": r4$ = "[(（][0-9]@[)）]"
    a = Array(r1, r2, r3, r4): b = Array(6, 5, 2, 11)
    c = Array("标题 2", "标题 3", "标题 4", "标题 5")
    For j = 0 To UBound(a)
        With doc.Content.Find
            Do While .Execute(a(j), , , 1)
                With .Parent
                    If Not .Information(wdWithInTable) Then
                        x = Len(.Text): ksr = .Text
                        .Expand 4: .Collapse
                        If .MoveWhile(ksr, x) = x Then
                            .Expand 4
                            .Style = doc.Styles("" & c(j) & "")
                            .Font.ColorIndex = b(j)
                            .Collapse 0
                        Else
                            .Move 4, 1
                        End If
                    End If
                End With
            Loop
        End With
    Next
End Sub

413191246se

略。。。。。。

duquancai

413191246se 发表于 2017-5-17 00:19
杜先生：在家里我的慢电脑上测试，这个《不受限制的宏》平均处理时间为 .318秒，比《正则表达式那个宏》平 ...

Sub 公文_自动排版_只排文字不排表格_正则处理方式()
    Dim doc As Document, a, b
    Set doc = ActiveDocument
'    文档预处理功能
    doc.Content.ListFormat.ConvertNumbersToText
    Call RGarr(doc, "^[\xa0\u3000\x20\t]+|[\xa0\u3000\x20\t]+(?=\r)", True)
    Call RGarr(doc, "\x0b", True, Chr(13))
    Call RGarr(doc, "\(", True, "（")
    Call RGarr(doc, "）、|\)", True, "）")
'    正文处理---（仅处理表格外段落)
    a = RGarr(doc, "^[^\r]+(?=\r)", False)
    If IsArray(a) = True Then
        For i = 1 To UBound(a)
            If Not a(i).Information(wdWithInTable) Then
                With a(i)
                    With .Font
                        .Name = "仿宋"
                        .Name = "Times New Roman"
                        .Size = 16
                        .Color = wdColorBlue '蓝色
                        .Kerning = 0
                        .DisableCharacterSpaceGrid = True
                    End With
                    With .ParagraphFormat
                        .LineSpacing = LinesToPoints(1.25)
                        .CharacterUnitFirstLineIndent = 2
                        .AutoAdjustRightIndent = False
                        .DisableLineHeightGrid = True
                    End With
                End With
            End If
        Next
    End If
'    标题处理---（仅处理表格外段落)
    sr$ = "〇一二三四五六七八九十百千万亿"
    r1$ = "^[" & sr & "]+、": r2$ = "^[(（]\s*[" & sr & "]+\s*[)）]"
    r3$ = "^\d+[、.．]": r4$ = "^[(（]\s*\d+\s*[)）]"
    b = RGarr(doc, "" & r2 & "|" & r1 & "|" & r4 & "|" & r3 & "", False)
    If IsArray(b) = True Then
        For i = 1 To UBound(b)
            If Not b(i).Information(wdWithInTable) Then
                With b(i)
                    .Expand 4: L = Len(.Text): .Collapse
                    If .MoveWhile(sr, L) > 0 Then
                        .Expand 4
                        .Style = ActiveDocument.Styles("标题 2")
                        .Font.ColorIndex = 6
                    ElseIf .MoveWhile("(（", L) > 0 Then
                        If .MoveWhile(sr, L) > 0 Then
                            .Expand 4
                            .Style = ActiveDocument.Styles("标题 3")
                            .Font.ColorIndex = 5
                        Else
                            .Expand 4
                            .Style = ActiveDocument.Styles("标题 5")
                            .Font.ColorIndex = 11
                        End If
                    Else
                        .Expand 4
                        .Style = ActiveDocument.Styles("标题 4")
                        .Font.ColorIndex = 2
                    End If
                End With
            End If
        Next
    End If
End Sub
Function RGarr(doc As Document, rg$, k As Boolean, Optional rp$ = "")
    Dim mt, mts As Object, reg As Object, n&, m&, j&, i&, arr()
    ostr$ = Replace(ActiveDocument.Content, Chr(7), "")
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    If k = True Then
        reg.Pattern = rg
        Set mts = reg.Execute(ostr)
        If Not mts Is Nothing Then
            For j = mts.Count - 1 To 0 Step -1
                m = mts(j).FirstIndex: n = mts(j).Length
                With doc.Range(m, m + n)
                    .Text = rp
                End With
            Next
        End If
    Else
        reg.Pattern = rg
        If reg.Execute(ostr).Count > 0 Then
            ReDim arr(1 To reg.Execute(ostr).Count)
            For Each mt In reg.Execute(ostr)
                i = i + 1: m = mt.FirstIndex: n = mt.Length
                Set arr(i) = doc.Range(m, m + n)
            Next
            RGarr = arr
        End If
    End If
End Function