1 Тема от AlexStar

  • AlexStar
  • подполковник
  • Неактивен
  • Откуда: Алматы
  • Зарегистрирован: 11.07.2017
  • Сообщений: 107
  • Поблагодарили: 24

Тема: Оглавление с помощью поля TC

Добрый день. Хочу поделиться решением, создания оглавления с помощью поля ТС. Искал информацию, как в те времена, когда я был

"Ты не умничай, ты пальцем покажи"
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"

2 Ответ от AlexStar

  • AlexStar
  • подполковник
  • Неактивен
  • Откуда: Алматы
  • Зарегистрирован: 11.07.2017
  • Сообщений: 107
  • Поблагодарили: 24

Re: Оглавление с помощью поля TC

Добрый день. Хочу поделиться решением, создания оглавления с помощью поля ТС. Искал информацию, как в те времена, когда я был "зеленым", то есть в прошлом веке, создавалось оглавление, например в word 6. Стилей то не было. Ничего не нашел. Но если я прав, то вспоминаем хорошо забытое старое. Честно сказать, я удивлен, почему MS не афиширует это решение в текущих версиях.

Sub TOCviaTC(control As IRibbonControl) '()

Dim SelectedText, getLevelNumber, LevelNumberString As String
Dim str, strfinal As String
Dim i, j As Integer


SelectedText = Selection.Range.Text                                                                                ' копируем выделенный фрагмент в переменную
getLevelNumber = Selection.Paragraphs(1).Range.ListFormat.ListLevelNumber                                          ' определяем уровень
                                                                                                                   'NumSelectedPrg = ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count

If Len(SelectedText) > 5 Then                                                                                      ' если в переменной что либо
SelectedText = "TC " & """" & SelectedText & """" & "\L" & getLevelNumber                                          'составляем строку для вставки поля
Selection.EndOf                                                                                                    ' переход выделения за последний символ
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, PreserveFormatting:=False, Text:=SelectedText     ' вставляем поле TC
Selection.moveLeft Unit:=wdCharacter, Count:=Len(SelectedText) - 2                                                 ' переводим курсор в начало текста для вставки следующего поля

myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)
For i = 1 To UBound(myHeadings)
    strfinal = ""
    j = 1
    LevelNumberString = Selection.Paragraphs(1).Range.ListFormat.ListString
    getLevelString = Trim(myHeadings(i))
    str = Mid(getLevelString, j, 1)
    
    While str <> " "
      strfinal = strfinal + str
      j = j + 1
      str = Mid(getLevelString, j, 1)
    Wend

 If strfinal = LevelNumberString Then
    On Error Resume Next
    
    If ActiveDocument.Paragraphs.Count <> ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count Then
       Selection.InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
                                                                          False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "

     Else
       ActiveDocument.Paragraphs.Add
       Selection.InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
                                                                          False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
       ActiveDocument.Paragraphs.Last.Range.Delete
     End If
    
    Selection.TypeText Text:=vbTab ' вставляем Tab
    Exit For
    End If
Next i
End If
End Sub

Прицепите этот макрос на кнопку. Включите отображение кода (полей) в тексте.

Выделите в тексте предложение, нажмите кнопку с данным кодом. Повторите это действие для тех предложений в тексте, которые должны попасть в оглавление.
Затем в начало текста вставьте поле {TOC \f} обновите.
Изюминка этого способа:
-возможность поместить в  оглавление отдельное предложение из параграфа содержащего несколько предложений.
- поместить в оглавление любой фрагмент текста.
-работает и обновляет многоуровневой список во всех вариантах стиля нумерации.
- создать оглавление в документе основанным на одном стиле. (ну, это обычное явление у пользователей)


Недостаток:  при изменении нумерации или стиля нумерации, необходимо обновить поля в документе, а затем обновить «содержание». (Ctrl+A), затем F9, затем фокус на оглавление, F9)

Если есть желание в оптимизации кода, то готов развести дискуссию…

"Ты не умничай, ты пальцем покажи"
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"

3 Ответ от AlexStar

  • AlexStar
  • подполковник
  • Неактивен
  • Откуда: Алматы
  • Зарегистрирован: 11.07.2017
  • Сообщений: 107
  • Поблагодарили: 24

Re: Оглавление с помощью поля TC

Sub TOCviaTC() - это первая строка кода, первое сообщение как то неудачно срезалось, упустил изменения во втором дубле. "Пребываю в глубоком пардоне".

"Ты не умничай, ты пальцем покажи"
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"

4 Ответ от AlexStar

  • AlexStar
  • подполковник
  • Неактивен
  • Откуда: Алматы
  • Зарегистрирован: 11.07.2017
  • Сообщений: 107
  • Поблагодарили: 24

Re: Оглавление с помощью поля TC

Допилил:

Sub TOCviaTC()
Dim SelectedText As String
Dim i As Integer

SelectedText = Selection.Range.Text                                                                                   ' копируем выделенный фрагмент в переменную
If Not Selection.Font.Bold Then
  Selection.Font.Bold = True
End If
                                     
If Len(SelectedText) > 5 Then                                                                                         ' если в переменной что либо
  SelectedText = "TC " & """" & SelectedText & """" & "\L" & Selection.Paragraphs(1).Range.ListFormat.ListLevelNumber 'составляем строку для вставки поля
  Selection.EndOf Unit:=wdWord, Extend:=wdMove
  
  Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, PreserveFormatting:=False, Text:=SelectedText       ' вставляем поле
  
  Selection.moveLeft Unit:=wdCharacter, Count:=Len(SelectedText) - 2                                                  ' переводим курсор в начало текста для вставки следующего поля
  myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)

  For i = 1 To UBound(myHeadings)
    If Mid(Trim(myHeadings(i)), 1, Len(Selection.Paragraphs(1).Range.ListFormat.ListString)) = Selection.Paragraphs(1).Range.ListFormat.ListString Then
    On Error Resume Next ' тут залипуха. При вставке поля в последний параграф текста, макрос вываливается.
    If ActiveDocument.Paragraphs.Count <> ActiveDocument.Range(0, Selection.Paragraphs(1).Range.End).Paragraphs.Count Then
       Selection.InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
       False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
    Else
       ActiveDocument.Paragraphs.Add
       Selection.InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
       False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
       ActiveDocument.Paragraphs.Last.Range.Delete
     End If
    
    Selection.TypeText Text:=vbTab ' вставляем Tab
    Exit For
    End If
Next i
End If
End Sub

Кстати, пример использования тут:внешняя ссылка

"Ты не умничай, ты пальцем покажи"
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"

5 Ответ от AlexStar

  • AlexStar
  • подполковник
  • Неактивен
  • Откуда: Алматы
  • Зарегистрирован: 11.07.2017
  • Сообщений: 107
  • Поблагодарили: 24

Re: Оглавление с помощью поля TC

Продолжаем монолог...
Добавил защиту от попытки пользователя затолкать в оглавление выделенный текст из двух параграфов. 

Sub TOCviaTC()
Dim SelectedText As String
Dim i As Integer

With Selection
If .Range.Paragraphs.Count <> 1 Then   ' проверка количества выделенных параграфов
   MsgBox "Не следует одновременно толкать в оглавление содержание 2-х параграфов!"
   Else
        If Len(.Range.Text) > 5 Then                                                                                       ' если в переменной что либо
              SelectedText = .Range.Text                                                                                   ' копируем выделенный фрагмент в переменную
              If Not .Font.Bold Then
                     .Font.Bold = True
              End If
        
              SelectedText = "TC " & """" & SelectedText & """" & "\L" & .Paragraphs(1).Range.ListFormat.ListLevelNumber 'составляем строку для вставки поля
              .EndOf Unit:=wdWord, Extend:=wdMove
              .Fields.Add Range:=.Range, Type:=wdFieldEmpty, PreserveFormatting:=False, Text:=SelectedText               ' вставляем поле
              .moveLeft Unit:=wdCharacter, Count:=Len(SelectedText) - 2                                                  ' переводим курсор в начало текста для вставки следующего поля
              myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)

              For i = 1 To UBound(myHeadings)
                 If Mid(Trim(myHeadings(i)), 1, Len(.Paragraphs(1).Range.ListFormat.ListString)) = .Paragraphs(1).Range.ListFormat.ListString Then
                 On Error Resume Next ' тут залипуха. При вставке поля в последний параграф текста, макрос вываливается.
                  If ActiveDocument.Paragraphs.Count <> ActiveDocument.Range(0, .Paragraphs(1).Range.End).Paragraphs.Count Then
                      .InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
                       False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                  Else
                      ActiveDocument.Paragraphs.Add
                      .InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
                       False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                      ActiveDocument.Paragraphs.Last.Range.Delete
                  End If
             .TypeText Text:=vbTab ' вставляем Tab
             Exit For
             End If
             Next i
       End If
End If
End With
End Sub
"Ты не умничай, ты пальцем покажи"
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"

6 Ответ от AlexStar

  • AlexStar
  • подполковник
  • Неактивен
  • Откуда: Алматы
  • Зарегистрирован: 11.07.2017
  • Сообщений: 107
  • Поблагодарили: 24

Re: Оглавление с помощью поля TC

Финал:

Sub TOCviaTC()
Dim SelectedText As String
Dim i As Integer

With Selection
If .Range.Paragraphs.Count <> 1 Then   ' проверка количества выделенных параграфов
   MsgBox "Не следует одновременно толкать в оглавление содержание 2-х параграфов!"
   Else
        If Len(.Range.Text) > 5 Then                                                                                       ' если в переменной что либо
              SelectedText = .Range.Text                                                                                   ' копируем выделенный фрагмент в переменную
              If Not .Font.Bold Then
                     .Font.Bold = True
              End If
        
              SelectedText = "TC " & """" & SelectedText & """" & "\L" & .Paragraphs(1).Range.ListFormat.ListLevelNumber 'составляем строку для вставки поля
              .EndOf Unit:=wdWord, Extend:=wdMove
              .Fields.Add Range:=.Range, Type:=wdFieldEmpty, PreserveFormatting:=False, Text:=SelectedText               ' вставляем поле
              .moveLeft Unit:=wdCharacter, Count:=Len(SelectedText) - 2                                                  ' переводим курсор в начало текста для вставки следующего поля
              myHeadings = ActiveDocument.GetCrossReferenceItems(wdRefTypeNumberedItem)

              For i = 1 To UBound(myHeadings)
                 If Mid(Trim(myHeadings(i)), 1, Len(.Paragraphs(1).Range.ListFormat.ListString)) = .Paragraphs(1).Range.ListFormat.ListString  And Len(.Paragraphs(1).Range.ListFormat.ListString) > 0 Then
                 On Error Resume Next ' тут залипуха. При вставке поля в последний параграф текста, макрос вываливается.
                  If ActiveDocument.Paragraphs.Count <> ActiveDocument.Range(0, .Paragraphs(1).Range.End).Paragraphs.Count Then
                      .InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
                       False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                  Else
                      ActiveDocument.Paragraphs.Add
                      .InsertCrossReference ReferenceType:=wdRefTypeNumberedItem, ReferenceKind:=wdNumberNoContext, ReferenceItem:=i, InsertAsHyperlink:= _
                       False, IncludePosition:=False, SeparateNumbers:=False, SeparatorString:=" "
                      ActiveDocument.Paragraphs.Last.Range.Delete
                  End If
             .TypeText Text:=vbTab ' вставляем Tab
             Exit For
             End If
             Next i
       End If
End If
End With
End Sub
"Ты не умничай, ты пальцем покажи"
"Кто поработал с многоуровневым списком в Ворде, тот в цирке не смеется"