如何删除标题前的文本编号(已有自动编号)

wan12327

各位老师好！我整理了多级列表的自动化编号代码。目前需要实现两个目标：

A.     运行下列程序后，删除标题前方的文本编号，保留自动编号

B.     调整自动编号的缩进情况及与文本的间隔

以下是我整理的代码，希望老师给与指导：

Sub 多级列表设置()

    Dimi As Paragraph

   Call ListTitle(ActiveDocument)

    ForEach i In ActiveDocument.Paragraphs

       If i.Range Like "#.#.#.#*" = True And i.Range.Font.Bold = TrueThen

           i.Style = wdStyleHeading4    '标题4是以1.1.1.1的形式开头的段落

           i.LineSpacing = LinesToPoints(1)

           i.SpaceAfter = 6

           i.SpaceBefore = 12

           i.Range.Font.Size = 11

       ElseIf i.Range Like "#.#.#*" = True And i.Range.Font.Bold =True Then

           i.Style = wdStyleHeading3    '标题3是以1.1.1的形式开头的段落

           i.LineSpacing = LinesToPoints(1)

           i.SpaceAfter = 6

           i.SpaceBefore = 12

           i.Range.Font.Size = 14

       ElseIf i.Range Like "#.#*" = True And i.Range.Font.Bold = TrueThen

           i.Style = wdStyleHeading2    '标题2是以1.1形式开头的段落

           i.LineSpacing = LinesToPoints(1)

           i.SpaceAfter = 6

           i.SpaceBefore = 12

           i.Range.Font.Size = 16

       ElseIf i.Range Like "#*" = True And i.Range.Font.Bold = TrueThen

           i.Style = wdStyleHeading1    '标题1是以1形式开头的段落

           i.LineSpacing = LinesToPoints(1)

           i.SpaceAfter = 6

           i.SpaceBefore = 12

           i.Range.Font.Size = 22

       End If

   Next

End Sub

Sub ListTitle(doc As Document)

    DimLtTemp As ListTemplate, i As Integer

    SetLtTemp = doc.ListTemplates.Add(True)

    Fori = 1 To 4

       With LtTemp.ListLevels(i)

           If i = 1 Then .NumberFormat = "%1": .NumberStyle = 0

           If i = 2 Then .NumberFormat = "%1.%2": .NumberStyle = 0

           If i = 3 Then .NumberFormat = "%1.%2.%3": .NumberStyle = 0

           If i = 4 Then .NumberFormat = "%1.%2.%3.%4": .NumberStyle = 0

       End With

    Next

End Sub

wan12327

杜老师的代码完美地解决了我的问题：

Sub 多级列表样式运用()
    r1$ = "^13[0-9]{1,}"
    r2$ = "^13[0-9]@.[0-9]{1,}"
    r3$ = "^13[0-9]@.[0-9]@.[0-9]{1,}"
    r4$ = "^13[0-9]@.[0-9]@.[0-9]@.[0-9]{1,}"
    a = Array(r1, r2, r3, r4)
    Call ListTitle(ActiveDocument)
    ActiveDocument.Content.InsertBefore vbCr
    For j = UBound(a) To 0 Step -1
        With ActiveDocument.Content.Find
            Do While .Execute(a(j), , , 1)
                With .Parent
                    .Start = .Start + 1: x = Len(.Text): ksr = .Text
                    .Expand 4: .Collapse
                    If .MoveWhile(ksr, x) = x Then
                        .MoveStart , -x: .Text = Empty
                        .Style = ActiveDocument.Styles("标题 " & j + 1)
                    Else
                        .Move 4, 1
                    End If
                End With
            Loop
        End With
    Next
    ActiveDocument.Paragraphs(1).Range.Text = Empty
End Sub

Sub ListTitle(doc As Document)
    Dim LtTemp As ListTemplate, i As Integer
    Set LtTemp = doc.ListTemplates.Add(True)
    For i = 1 To 4
        With LtTemp.ListLevels(i)
            If i = 1 Then .NumberFormat = "%1"
            If i = 2 Then .NumberFormat = "%1.%2"
            If i = 3 Then .NumberFormat = "%1.%2.%3"
            If i = 4 Then .NumberFormat = "%1.%2.%3.%4"
            .NumberStyle = 0  '37
            .TrailingCharacter = 2: .StartAt = 1: .ResetOnHigher = True
            .TextPosition = InchesToPoints(0.1 * i)
            .NumberPosition = InchesToPoints(0.1 * (i - 1))
            '.LinkedStyle = "标题 " & i
        End With
    Next
End Sub