查看标题格式是否正确

kerry786032

工作原因，设计了一个功能，查看标题格式是否正确，但是标题有一级标题，二级标题，三级标题，所以我就分别写了三种判断方式，然后回调。但是我感觉可以写成一个判断，自己尝试很久没搞出来，新人刚刚自学，想请教下老师怎么把这三种判断写成一种。正确的格式是（1.或者1.1. 或者1.1.1.）就有人经常忘记在最后的数字后面加点，工作要求把这种情况标记出来。
Sub First_Leve_title()
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Text = "^13[0-9] [A-Z]*^13"
    .MatchWildcards = True
    .Wrap = wdfindcontine
    .Forward = True
    Do
        .Execute
        If Not .Found Then
        Exit Do
        End If
        If .Found Then
        Selection.Comments.Add Range:=Selection.Range.Words(2), Text:="A " & ChrW(34) & "." & ChrW(34) & " is needed behind of The numbers (1.2.)."
        End If
          Loop
    End With
     Selection.HomeKey unit:=wdStory
End Sub


Sub second_title()
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "^13[0-9].[0-9] [A-Z]*^13"
    .MatchWildcards = True
    .Wrap = wdfindcontine
    .Forward = True
    Do
        .Execute
        If Not .Found Then
        Exit Do
        End If
        If .Found Then
        Selection.Comments.Add Range:=Selection.Range.Words(2), Text:="A " & ChrW(34) & "." & ChrW(34) & " is needed behind of The numbers (1.2.)."
        End If
Loop
    End With
    Selection.HomeKey unit:=wdStory
End Sub


Sub three_title()
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
    With Selection.Find
    .Text = "^13[0-9].[0-9].[0-9] [A-Z]*^13"
    .MatchWildcards = True
    .Wrap = wdfindcontine
    .Forward = True
    Do
        .Execute
        If Not .Found Then
        Exit Do
        End If
        If .Found Then
        Selection.Comments.Add Range:=Selection.Range.Words(2), Text:="A " & ChrW(34) & "." & ChrW(34) & " is needed behind of The numbers (1.2.)."
        End If
        Loop  
    End With
    Selection.HomeKey unit:=wdStory
End Sub

duquancai

Sub 标记不正确的编号()
    Dim mt, reg As Object, d As Document
    Set d = ActiveDocument
    If d.Content.Comments.Count <> 0 Then
        For i = d.Content.Comments.Count To 1 Step -1
            d.Content.Comments(i).Delete
        Next
    End If
    d.Content.HighlightColorIndex = 0
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    reg.Pattern = "^(?:(?:\d+\.){1,2}\d+(?!\.)|\d+(?!\.))"
    For Each mt In reg.Execute(d.Content.Text)
        m = mt.FirstIndex: n = mt.Length
        With d.Range(m, m + n)
            .HighlightColorIndex = 6
        End With
    Next
End Sub

kerry786032

duquancai 发表于 2017-10-2 16:04
Sub 标记不正确的编号()
    Dim mt, reg As Object, d As Document
    Set d = ActiveDocument

谢谢老师的指导，正则好强大，我应该去认真学习下。

kerry786032

|就是或的意思啊，哈哈

13907933959

duquancai 发表于 2017-10-2 16:04
Sub 标记不正确的编号()
    Dim mt, reg As Object, d As Document
    Set d = ActiveDocument

杜前辈好！
这个我也经常碰到，想劳前辈给一个一步到位的代码，把不正确的编号直接纠正，谢谢！

duquancai

13907933959 发表于 2017-10-3 07:04
杜前辈好！
这个我也经常碰到，想劳前辈给一个一步到位的代码，把不正确的编号直接纠正，谢谢！

Sub 修正错误编号()
'    文档为纯文本
    Dim mts, reg As Object, d As Document
    Set d = ActiveDocument
    Set reg = CreateObject("vbscript.regexp")
    reg.Global = True: reg.MultiLine = True
    reg.Pattern = "^(?:(?:\d+\.)+\d+(?!\.)|\d+(?!\.))"
    Set mts = reg.Execute(d.Content.Text)
    If Not mts Is Nothing Then
        For j = mts.Count - 1 To 0 Step -1
            m = mts(j).FirstIndex: n = mts(j).Length
            With d.Range(m, m + n)
                .InsertAfter "."
            End With
        Next
    End If
End Sub

13907933959

duquancai 发表于 2017-10-3 09:05
Sub 修正错误编号()
'    文档为纯文本
    Dim mts, reg As Object, d As Document

杜前辈好！
代码准确无误，感谢前辈！谢谢！

wdpfox

感谢杜老师的代码，谢谢！