Word VBA Макросы: Как преобразовать списки в текст?

[Svetik]

Добрый вечер! Скажите, пожалуйста, как преобразовать списки в текст?

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

Запускайте процедуру "pLists". Процедура "pConvertLists" будет запущена процедурой "pLists".

Макрос

Sub pLists()
   
    ' Превращение списков в текст и некоторые настройки.
    Call pConvertLists

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

Private Sub pConvertLists()
   
    ' Превращение списков в текст и некоторые настройки.
   
    Dim par As Paragraph
    Dim lngSign As Long, i As Long
   
   
    For i = ActiveDocument.ListParagraphs.Count To 1 Step -1
        ' Vba-именование абзаца.
        Set par = ActiveDocument.ListParagraphs(i)
        ' Если абзац внутри таблицы, то не обрабатываем такой абзац.
        If par.Range.Information(wdWithInTable) = True Then
            GoTo metkaNextListPar
        End If
        ' Запись юникод-кода маркера.
        lngSign = AscW(par.Range.ListFormat.ListString)
        ' Если маркер это тире (-4051) или дефис (45).
        If (lngSign = -4051) Or (lngSign = 45) Then
            ' Превращение списка в текст.
            par.Range.ListFormat.ConvertNumbersToText
            ' Замена дефиса на тире.
            If lngSign = 45 Then
                par.Range.Characters(1).Text = ChrW(-4501)
            End If
            ' Настройка параметров абзаца.
            par.LeftIndent = CentimetersToPoints(0)
            par.RightIndent = CentimetersToPoints(0)
            par.FirstLineIndent = CentimetersToPoints(1.25)
            ' Установка табуляции.
            par.Range.ParagraphFormat.TabStops.ClearAll
            par.Range.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(1.75), _
                Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        End If
metkaNextListPar:
    Next i
   
End Sub

[свернуть]

[Svetik]

Большое спасибо! Проверила - на моих маркированных списках работает.

[Anton]

Добрый день!
Мне что-то везет на необычные варианты документов с ошибками. Есть у меня документ, использую макрос из этой темы, а он выдает ошибку. Прикрепил. Как можно избежать ошибки? Хочется, чтобы макрос все-таки отработал весь документ до конца.

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

Наверное, очередной брак в ворде: списков нет, но vba и сам ворд видит список (вкладка "Главная" - группа "Абзац" - вдавлена кнопка маркированных списков "Маркеры"). По идее, если есть список, значит должен быть маркер. Или есть списки без маркеров?

Макрос

Sub pLists()
   
    ' Превращение списков в текст и некоторые настройки.
    Call pConvertLists

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

Private Sub pConvertLists()
   
    ' Превращение списков в текст и некоторые настройки.
   
    Dim par As Paragraph
    Dim lngSign As Long, i As Long
   
   
    For i = ActiveDocument.ListParagraphs.Count To 1 Step -1
        ' Vba-именование абзаца.
        Set par = ActiveDocument.ListParagraphs(i)
        ' Если абзац внутри таблицы, то не обрабатываем такой абзац.
        If par.Range.Information(wdWithInTable) = True Then
            GoTo metkaNextListPar
        End If
        ' Если в абзаце нет маркеров. Это наверное брак в ворде.
        If par.Range.ListFormat.ListString = "" Then
            GoTo metkaNextListPar
        End If
        ' Запись юникод-кода маркера.
        lngSign = AscW(par.Range.ListFormat.ListString)
        ' Если маркер это тире (-4051) или дефис (45).
        If (lngSign = -4051) Or (lngSign = 45) Then
            ' Превращение списка в текст.
            par.Range.ListFormat.ConvertNumbersToText
            ' Замена дефиса на тире.
            If lngSign = 45 Then
                par.Range.Characters(1).text = ChrW(-4501)
            End If
            ' Настройка параметров абзаца.
            par.LeftIndent = CentimetersToPoints(0)
            par.RightIndent = CentimetersToPoints(0)
            par.FirstLineIndent = CentimetersToPoints(1.25)
            ' Установка табуляции.
            par.Range.ParagraphFormat.TabStops.ClearAll
            par.Range.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(1.75), _
                Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        End If
metkaNextListPar:
    Next i
   
End Sub

[свернуть]

[Anton]

Но что-то на моем примере у меня ничего не происходит.

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

А что должно происходить?

[Anton]

Ну список должен быть текстом, а кнопка список все также утоплена.

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

Макрос

Sub pLists()
   
    ' Превращение списков в текст и некоторые настройки.
    Call pConvertLists

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

Private Sub pConvertLists()
   
    ' Превращение списков в текст и некоторые настройки.
   
    Dim par As Paragraph
    Dim lngSign As Long, i As Long
   
   
    For i = ActiveDocument.ListParagraphs.Count To 1 Step -1
        ' Vba-именование абзаца.
        Set par = ActiveDocument.ListParagraphs(i)
        ' Если абзац внутри таблицы, то не обрабатываем такой абзац.
        If par.Range.Information(wdWithInTable) = True Then
            GoTo metkaNextListPar
        End If
        ' Если в абзаце нет маркеров. Это наверное брак в ворде.
        If par.Range.ListFormat.ListString = "" Then
            par.Range.ListFormat.ConvertNumbersToText
            GoTo metkaNextListPar
        End If
        ' Запись юникод-кода маркера.
        lngSign = AscW(par.Range.ListFormat.ListString)
        ' Если маркер это тире (-4051) или дефис (45).
        If (lngSign = -4051) Or (lngSign = 45) Then
            ' Превращение списка в текст.
            par.Range.ListFormat.ConvertNumbersToText
            ' Замена дефиса на тире.
            If lngSign = 45 Then
                par.Range.Characters(1).text = ChrW(-4501)
            End If
            ' Настройка параметров абзаца.
            par.LeftIndent = CentimetersToPoints(0)
            par.RightIndent = CentimetersToPoints(0)
            par.FirstLineIndent = CentimetersToPoints(1.25)
            ' Установка табуляции.
            par.Range.ParagraphFormat.TabStops.ClearAll
            par.Range.ParagraphFormat.TabStops.Add Position:=CentimetersToPoints(1.75), _
                Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
        End If
metkaNextListPar:
    Next i
   
End Sub

[свернуть]

[Anton]

Да! Ура! Все сработало! Огромное спасибо за помощь и терпение!

[monten]

Здравствуйте!
У меня сходная проблема: в большом документе (примерно 500 стр.) нужно заменить маркированный список на текст (вместо маркера - тире (En Dash)). В маркированном списке стоят длинные тире, но шрифт у этих маркеров - "Symbol". Видимо, из-за этого у меня не получается задать в коде макроса условие поиска - код этого длинного тире.
Вы не могли бы подсказать, какой код использовать?
Фрагмент файла приложил.

Большое спасибо!

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

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

Для вашего файла макрос.

Макрос

Sub макрос()
   
    Dim par As Paragraph, marker As Long, i As Long
   
   
    ' Отключение монитора (может это ускорит макрос).
    Application.ScreenUpdating = False
   
    ' Цикл по всем абзацам, в которых есть список.
        ' Цикл от последнего к первому, т.к. после замены списка на текст
        ' абзац не будет содержать список и нумерация абзацев-списков изменится
        ' и переход уже не произойдёт к нужному абзацу-списку, а будет перескок.
    For i = ActiveDocument.ListParagraphs.Count To 1 Step -1
   
        '1. Присваиваем абзацу имя "par", чтобы было удобно читать и писать код.
        Set par = ActiveDocument.ListParagraphs(i)
       
        '2. Запись юникод-кода маркера в переменную "marker".
        marker = AscW(par.Range.ListFormat.ListString)
       
        ' Смотрим, что в переменной "marker".
        Select Case marker
       
            ' Если маркер это тире или дефис.
                ' -4051, -3906 - тире.
                ' 45 - дефис.
            Case -3906, -4051, 45
           
                '3. Превращение списка в текст.
                par.Range.ListFormat.ConvertNumbersToText
               
                '4. Задаём шрифт для маркера и для символа "табуляция". Шрифт будет, как у текста.
                    ' Для этого смотрим шрифт третьего символа абзаца.
                    ' У маркера делаем шрифт, чтобы тире выглядело как тире.
                    ' У символа "табуляция" изменяем шрифт просто, чтобы не было
                    ' ничего лишнего в файле.
                par.Range.Characters(1).Font.Name = par.Range.Characters(3).Font.Name
                par.Range.Characters(2).Font.Name = par.Range.Characters(3).Font.Name
               
                '5. Замена тире, дефиса на тире "En Dash".
                par.Range.Characters(1).Text = Chr(150)
               
                '6. Замена символа "табуляция" на неразрывный пробел, чтобы текст был рядом с тире.
                par.Range.Characters(2).Text = Chr(160)
               
        End Select
   
    Next i
   
    ' Вкл. монитора.
    Application.ScreenUpdating = True
   
    '6. Сообщение.
    MsgBox "Готово.", vbInformation

End Sub

[свернуть]

[monten]

Большое спасибо!
Всё работает! Это великолепно!