Word VBA Макросы: Ошибка 4605 при работе со списками

[Anton]

Добрый день! Помогите пожалуйста разобраться!

Вот макрос (разные части взяты на форуме), который приводит списки в похожий вид.

Прилагаю документ, где ругается на ошибку:
Rrun-time error 4605
Метод или свойство недопустимы, поскольку возникла проблема с оперативной памятью или с диском

Макрос

Sub МакросСписки()

Dim Par As Paragraph, lstlevel As ListLevel, i As Long

    For Each list In ActiveDocument.Lists
        list.ListParagraphs(1).SelectNumber
        Selection.Font.Size = list.ListParagraphs(1).Range.Characters(1).Font.Size
        Selection.Font.Name = list.ListParagraphs(1).Range.Characters(1).Font.Name
        Selection.Font.Bold = list.ListParagraphs(1).Range.Characters(1).Font.Bold
        Selection.Font.Italic = list.ListParagraphs(1).Range.Characters(1).Font.Italic
    Next list

    '2. Удаление табуляторов с линейки.
    For i = 1 To ActiveDocument.ListParagraphs.count Step 1
        ActiveDocument.ListParagraphs(i).TabStops.ClearAll

        ActiveDocument.ListParagraphs(i).TabStops.add Position:=CentimetersToPoints(1.75), _
                                                       Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces

    Next i

    '3. Замена символов "Табуляция" на пробелы.
    For i = 1 To ActiveDocument.Lists.count Step 1

        ' Vba-именование первого абзаца-списка.
        Set Par = ActiveDocument.Lists(i).ListParagraphs(1)

        ' Интересуют списки с нумерацией (не обычные маркированные).
        Select Case Par.Range.ListFormat.ListType
        Case wdListListNumOnly, wdListMixedNumbering, wdListOutlineNumbering, wdListSimpleNumbering
            ' Цикл по всем уровням списка.
            For Each lstlevel In Par.Range.ListFormat.ListTemplate.ListLevels

            lstlevel.NumberPosition = CentimetersToPoints(1.25)
            lstlevel.TextPosition = CentimetersToPoints(0)

                ' Проверка, есть ли пробел после номера.
                If lstlevel.TrailingCharacter <> wdTrailingSpace Then
                    ' Установка пробела в шаблоне списка.
                    lstlevel.TrailingCharacter = wdTrailingSpace
                End If
            Next lstlevel
        End Select
    Next i

'сразу после любого оператора тут выводит ошибку 4605

End sub

[свернуть]

[вложение удалено администратором]

[Администратор]

Опытным путём нашёл, что вызывает ошибку этот код.

Код

    '3. Замена символов "Табуляция" на пробелы.
    For i = 1 To ActiveDocument.Lists.Count

       ' Vba-именование первого абзаца-списка.
       Set Par = ActiveDocument.Lists(i).ListParagraphs(1)

       ' Интересуют списки с нумерацией (не обычные маркированные).
       Select Case Par.Range.ListFormat.ListType
           Case wdListListNumOnly, wdListMixedNumbering, wdListOutlineNumbering, wdListSimpleNumbering
   
               ' Цикл по всем уровням списка.
               For Each lstlevel In Par.Range.ListFormat.ListTemplate.ListLevels
   
                   lstlevel.NumberPosition = CentimetersToPoints(1.25)
                   lstlevel.TextPosition = CentimetersToPoints(0)
   
                   ' Проверка, есть ли пробел после номера.
                   If lstlevel.TrailingCharacter <> wdTrailingSpace Then
   
                       ' Установка пробела в шаблоне списка.
                       lstlevel.TrailingCharacter = wdTrailingSpace
   
                   End If
   
               Next lstlevel
   
        End Select

    Next i

[свернуть]

[Администратор]

For Each list In ActiveDocument.Lists
    Цикл по всем спискам в файле. В каждом витке цикла списку присваивается имя "list" и затем можно работать со списком, используя имя "list", - пишите "list", ставите точку и выбираете нужный член.

Set par = list.ListParagraphs(1)
    Напрямую не получается работать со списком, а можно это сделать через любой абзац списка. В данном случае используется первый абзац. Ему присваивается имя "par" и затем можно обращаться к абзацу по этому имени.

Select Case par.Range.ListFormat.ListType
    Узнаём вид списка. В комментарии об этом написано.

For Each lstlevel In par.Range.ListFormat.ListTemplate.ListLevels
    Цикл по уровням списка. У списков есть первый уровень, второй и до девятого. Это можно посмотреть в самом ворде.

[Администратор]

Обходной вариант - используйте сохранение файла после нескольких изменений. Этот макрос сохраняет файл через каждые сто изменений.

Макрос

Sub МакросСписки_2()

    Dim list As list, listlevel As listlevel, par As Paragraph
    Dim counter As Long
   

    ' Цикл по всем спискам в активном файле.
    For Each list In ActiveDocument.Lists

        ' Vba-именование первого абзаца-списка.
        Set par = list.ListParagraphs(1)

        ' Интересуют списки с нумерацией (не обычные маркированные).
        Select Case par.Range.ListFormat.ListType
            Case wdListListNumOnly, wdListMixedNumbering, wdListOutlineNumbering, wdListSimpleNumbering
   
                ' Цикл по всем уровням списка.
                For Each listlevel In par.Range.ListFormat.ListTemplate.ListLevels
                   
                    If listlevel.NumberPosition <> CentimetersToPoints(1.25) Then
                        listlevel.NumberPosition = CentimetersToPoints(1.25)
                        counter = counter + 1
                    End If
                    If listlevel.TextPosition <> CentimetersToPoints(0) Then
                        listlevel.TextPosition = CentimetersToPoints(0)
                        counter = counter + 1
                    End If
               
                    ' Проверка, есть ли пробел после номера.
                    If listlevel.TrailingCharacter <> wdTrailingSpace Then
                        ' Установка пробела в шаблоне списка.
                        listlevel.TrailingCharacter = wdTrailingSpace
                        counter = counter + 1
                    End If
               
                Next listlevel
               
                If counter > 100 Then
                    ActiveDocument.Save
                    counter = 0
                End If
               
        End Select

    Next list

    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[Anton]

Мне этот вариант не подходит, т.к. надо создавать копию файла перед запуском макроса,, а это неудобно.