根据 Word 文档中的标题生成相对于特定标题的树状层次结构

Question

我有时必须就某个项目的规格撰写提案，大多数时候是网站。我喜欢在其中添加一个“大纲”部分，它基本上是网站所有部分的树状层次结构。这些部分几乎与标题一一对应。想象一下文档中的以下标题结构。

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

在里面项目概要部分，然后我创建一个SmartArt > 水平层次结构控件，并在其下填充基本相同的内容项目信息标题。查看下面所附图片，了解其外观。

我说几乎相同的内容，因为我有时会添加内容，就像图片中那样各种面板，其中没有实际的标题，但显示在大纲中。

问题是，随着时间的推移，如果提案经过多次迭代，我必须手动更新这个层次结构，这很麻烦，因为它主要基于标题。有没有办法从文档本身自动生成类似的内容，说明你会选择项目信息作为相关节点，并且它的子节点生成为树，并且仍然允许您在所需的位置添加自定义节点？

Answer 1

您可以尝试以下宏。它假设您的标题是使用标准标题样式的段落（否则，实现 AFAICS 会变得更加困难）。如果您的标题级别不是严格的层次结构，它将尝试做一些合理的操作，但您可以根据需要修复宏。

备份您的文档。

修改子“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