Добрый день! Помогите пожалуйста разобраться!
Вот макрос (разные части взяты на форуме), который приводит списки в похожий вид.
Прилагаю документ, где ругается на ошибку:
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
Мне этот вариант не подходит, т.к. надо создавать копию файла перед запуском макроса,, а это неудобно.