word-VBA 顺题号

Sub 试卷顺题号()
    '作者  DG-wang
    '时间  2021-01-28
    '用途  试卷重新顺题号
    '未解决的问题  “ 1．2008年 ”这样的文本
    Const MAX_INDEX As Integer = 20 '设定修改题号的上限值
    Dim doc As Document '声明word文档变量
    Dim para As Paragraph '声明段落变量
    Dim newText As String '声明字符串变量
    Dim index As Integer '声明题号变量
    Dim Regex As Object '声明正则对象变量
    Set Regex = CreateObject("VBScript.RegExp") '实例化正则对象
    Regex.Global = True '设置全局属性
    Regex.Pattern = "\d{1,2}(．\D)" '设置匹配范式
    Set doc = ActiveDocument '实例化文档
    index = 0 '初始化题号
    '循环所有段落
    For i = 1 To doc.Paragraphs.Count
        Set para = doc.Paragraphs(i)
        '检查段落特征是否符合预期
        If Regex.Test(para.Range.Text) Then
            index = index + 1 '题号递增1
            '替换题号 $1 为匹配范式里括号内的内容
            newText = Regex.Replace(para.Range.Text, index & "$1")
            Debug.Print index, "原段落>>", para.Range.Text, "替换为>>"; newText
            'para.Range.Select
            para.Range.Text = newText
            'Selection.Collapse wdCollapseEnd
        End If
        If index = MAX_INDEX Then Exit For
    Next
    '释放变量
    Set doc = Nothing
    Set para = Nothing
    Set Regex = Nothing
End Sub

　　今天实践了一下，发现之前的做法会将段落内的嵌入图形替换掉，于是重新修改了一下做法

Sub 试卷顺题号()
    '作者  DG-wang
    '时间  2021-02-23
    '用途  试卷重新顺题号
    Const MAX_INDEX As Integer = 20 '设定修改题号的上限值
    Dim doc As Document '声明word文档变量
    Dim p As Paragraph '声明段落变量
    Dim newText As String '声明字符串变量
    Dim index As Integer '声明题号变量
    Dim Regex As Object '声明正则对象变量
    Set Regex = CreateObject("VBScript.RegExp") '实例化正则对象
    Regex.Global = True '设置全局属性
    Regex.Pattern = "^\s*(\d{1,2})．\s*?\S" '正则表达式
    Set doc = ActiveDocument '实例化文档
    index = 0 '初始化题号
    '循环所有段落
    For i = 1 To doc.Paragraphs.Count
        Set p = doc.Paragraphs(i)
        If Regex.test(p.Range.Text) Then
            Set ms = Regex.Execute(p.Range.Text)
            Debug.Print ms(0)
            index = index + 1
            p.RangeSub 试卷顺题号()
    '作者  DG-wang
    '时间  2021-02-23
    '用途  试卷重新顺题号
    Const MAX_INDEX As Integer = 20 '设定修改题号的上限值
    Dim doc As Document '声明word文档变量
    Dim p As Paragraph '声明段落变量
    Dim newText As String '声明字符串变量
    Dim index As Integer '声明题号变量
    Dim Regex As Object '声明正则对象变量
    Set Regex = CreateObject("VBScript.RegExp") '实例化正则对象
    Regex.Global = True '设置全局属性
    Regex.Pattern = "^\s*(\d{1,2})．\s*?\S" '正则表达式
    Set doc = ActiveDocument '实例化文档
    index = 0 '初始化题号
    '循环所有段落
    For i = 1 To doc.Paragraphs.Count
        Set p = doc.Paragraphs(i)
        If Regex.test(p.Range.Text) Then
            Set ms = Regex.Execute(p.Range.Text)
            Debug.Print ms(0)
            index = index + 1
            p.Range.Select
            With Selection.Find
                .Text = ms(0)
                .Replacement.Text = Replace(ms(0), ms(0).submatches(0), index)
                .Execute Replace:=wdReplaceOne
            End With
           If index >= MAX_INDEX Then Exit For
        End If
    Next i
    
    '释放变量
    Set doc = Nothing
    Set p = Nothing
    Set Regex = Nothing
End Sub.Select
            With Selection.Find
                .Text = ms(0)
                .Replacement.Text = Replace(ms(0), ms(0).submatches(0), index)
                .Execute Replace:=wdReplaceOne
            End With
           If index >= MAX_INDEX Then Exit For
        End If
    Next i
    
    '释放变量
    Set doc = Nothing
    Set p = Nothing
    Set Regex = Nothing
End Sub