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