генерировать древовидную иерархию на основе заголовков в текстовом документе относительно определенного заголовка

Иногда мне приходится писать предложения по спецификациям проекта, чаще всего веб-сайта. Мне нравится включать раздел «контур», который представляет собой древовидную иерархию всех разделов веб-сайта. Они соответствуют почти один к одному с заголовком. Представьте себе структуру заголовка ниже в документе.

Project
Revision History
Table of Contents
Project Outline
Project Information
    Homepage
        Interactive Banner
        Various Panels
        Search
        Login
    Common Components
        Current Weather
        Social Networking Icons
        Contact Details
        Live Chat
    Content Pages
        Gallery
        Comments
    Contact Us

В Outline проекта раздела, я затем создать SmartArt> Горизонтальные иерархии управления, и заполнить его в основном почти того же содержания под Project Информация заголовка. Посмотрите на изображение ниже, чтобы понять, как это будет выглядеть.

Я сказал почти то же самое содержание, потому что я иногда добавляю к нему, как это показано на изображении в разделе « Различные панели» , где для них нет реальных заголовков, но они показаны на схеме.

Проблема в том, что со временем, если предложение проходит через различные итерации, становится головной болью, когда приходится вручную обновлять эту иерархию, поскольку она основана главным образом на заголовках. Есть ли способ, чтобы нечто подобное можно было автоматически сгенерировать из самого документа, говоря, что вы выбрали бы « Сведения о проекте» в качестве релевантного узла, а его дочерние элементы были сгенерированы как дерево, и все же позволяли бы вам добавлять собственные узлы там, где вы хотите?

Вы можете попробовать следующий макрос. Предполагается, что ваши заголовки - это абзацы, в которых используются стандартные стили заголовков (в противном случае получить AFAICS становится намного сложнее). Он попытается сделать что-то разумное, если ваши уровни заголовков не являются строгой иерархией, но вы должны исправить макрос по мере необходимости.

Сделайте резервную копию вашего документа.

Измените sub "testMakeHierarchy", чтобы найти текст заголовка, который указывает поддерево заголовка, которое вы хотите использовать. Затем в документе щелкните там, где вы хотите диаграмму, а затем запустите макрос.

Если у вас уже есть диаграмма, я предлагаю вам щелкнуть рядом с существующей диаграммой, запустить макрос, а затем удалить старую диаграмму, если она вам больше не нужна.

Sub testMakeHierarchy()
' change the text "Project Information" as appropriate
' Click where you want the diagram
' then run this sub.
Call makeHierarchy(Selection.Range, _
  "urn:microsoft.com/office/officeart/2005/8/layout/hierarchy2", _
  "Project Information")
End Sub

Sub makeHierarchy(rngLocation As Word.Range, strLayout As String, strTopLevelText As String)
' Inserts a Hierarchy SmartArt diagram
' - at the location specified by rngLocation,
' - using the SmartArtLayout defined by strLayout
' - taking text from all the Heading n paragraph styles
'    from the Heading paragraph with text strTopLevelText
'    to the next Heading paragraph with the same level
'    or the end of document
'    strMatchHeadingStyle is a string used to match styles - see testMakeHierarchy for an example.

' Currently makes a number of kludgy assumptions, the main one being that
' if (say) the starting point is a Heading 2 paragraph, the next para will be Heading 3
Const theFontName As String = "Arial"
Const thePlaceholderText As String = "[Placeholder]"
Dim bContinue As Boolean
Dim bDiagramCreated As Boolean
Dim intLevel As Integer
Dim intBoxCount As Integer
Dim intCurrentLevel As Integer
Dim intPreviousLevel As Integer
Dim intStartingLevel As Integer
Dim intHWMLevel As Integer
Dim lngPreviousStart As Long
Dim objDocument As Word.Document
Dim rng As Word.Range
Dim san As Office.SmartArtNode
Dim sanl(9) As Office.SmartArtNode
Dim shp As Word.InlineShape

bContinue = True
' set the range to the first paragraph in the containing Document
Set objDocument = rngLocation.Parent
Set rng = objDocument.Content.GoTo(wdGoToHeading, wdGoToFirst)
If headingLevel(rng) = 10 Then
  bContinue = False
Else
  bContinue = True
  lngPreviousStart = rng.Start
  While bContinue And (rng.Paragraphs(1).Range.Text <> (strTopLevelText & vbCr))
    Set rng = rng.GoToNext(wdGoToHeading)
    bContinue = (rng.Start <> lngPreviousStart)
    lngPreviousStart = rng.Start
  Wend
End If

If Not bContinue Then
  MsgBox "Could not find a Heading paragraph containing just the text """ & strTopLevelText & """", vbOKOnly
Else
  intStartingLevel = headingLevel(rng)
  intPreviousLevel = intStartingLevel
  bDiagramCreated = False
  Set rng = rng.GoToNext(wdGoToHeading)
  intCurrentLevel = headingLevel(rng)
  While (rng.Start > lngPreviousStart) And (intCurrentLevel > intStartingLevel)
    ' we have got one Heading with a lower level
    ' so start creating our hierarchy diagram
    If Not bDiagramCreated Then
      ' Create and empty the shape
      Set shp = rngLocation.InlineShapes.AddSmartArt(Application.SmartArtLayouts(strLayout), rngLocation)
      With shp.SmartArt
        For i = .AllNodes.Count To 1 Step -1
          .AllNodes(i).Delete
        Next
      End With
      Set sanl(intCurrentLevel) = shp.SmartArt.Nodes.Add
      intHWMLevel = intCurrentLevel
      bDiagramCreated = True
    Else
      If intCurrentLevel = intPreviousLevel Then
        Set sanl(intCurrentLevel) = sanl(intCurrentLevel).AddNode(msoSmartArtNodeAfter)
      Else
        If intCurrentLevel > intPreviousLevel Then
          For intLevel = intPreviousLevel + 1 To intCurrentLevel
            If Not (sanl(intLevel) Is Nothing) Then
              Set sanl(intLevel) = Nothing
            End If
            Set sanl(intLevel) = sanl(intLevel - 1).AddNode(msoSmartArtNodeBelow)
            If intLevel < intCurrentLevel Then
              With sanl(intLevel).TextFrame2.TextRange
                .Text = thePlaceholderText
                .Font.Name = theFontName
              End With
            End If
          Next
        Else ' higher level than previous
          If sanl(intCurrentLevel) Is Nothing Then
            Set sanl(intCurrentLevel) = sanl(intHWMLevel).AddNode(msoSmartArtNodeAfter)
          Else
            Set sanl(intCurrentLevel) = sanl(intCurrentLevel).AddNode(msoSmartArtNodeAfter)
          End If
        End If
      End If
    End If
    With sanl(intCurrentLevel).TextFrame2
      With .TextRange
         .Text = Left(rng.Paragraphs(1).Range.Text, Len(rng.Paragraphs(1).Range.Text) - 1)
         .Font.Name = "Arial"
      End With
    End With
    lngPreviousStart = rng.Start
    intPreviousLevel = intCurrentLevel
    Set rng = rng.GoToNext(wdGoToHeading)
    intCurrentLevel = headingLevel(rng)
  Wend
  If bDiagramCreated Then
    For intLevel = 1 To 9
      Set sanl(intLevel) = Nothing
    Next
    Set shp = Nothing
  Else
    MsgBox "No suitable headings found.", vbOKOnly
  End If
End If
skip:
Set rng = Nothing
Set objDocument = Nothing
End Sub


Function headingLevel(rng As Word.Range) As Integer
' looks at the first paragraph in Range rng
' returns 1 - 9 for heading styles 1 to 9, 10 for any other style
Dim d As Word.Document
Dim s As Word.Style
' AFAIK we have to assign a Style object, otherwise we
' just get a variant
With rng
  Set d = rng.Parent
  Set s = .Paragraphs(1).Style
  Select Case s.NameLocal
    Case d.Styles(Word.WdBuiltinStyle.wdStyleHeading1).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading2).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading3).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading4).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading5).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading6).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading7).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading8).NameLocal, _
            d.Styles(Word.WdBuiltinStyle.wdStyleHeading9).NameLocal
        headingLevel = s.ListLevelNumber
      Case Else
        headingLevel = 10
  End Select
  Set s = Nothing
  Set d = Nothing
End With
End Function