Bạn có thể thử macro sau. Nó giả định rằng các tiêu đề của bạn là các đoạn sử dụng Kiểu tiêu đề tiêu chuẩn (nếu không, việc đạt được AFAICS trở nên khó khăn hơn rất nhiều). Nó sẽ cố gắng làm điều gì đó hợp lý nếu các cấp Heading của bạn không phải là một hệ thống phân cấp chặt chẽ, nhưng tùy thuộc vào bạn để sửa macro theo yêu cầu.
Sao lưu tài liệu của bạn.
Sửa đổi phụ "testMakeHVELy" để tìm văn bản Tiêu đề cho biết cây con tiêu đề bạn muốn sử dụng. Sau đó trong tài liệu, bấm vào nơi bạn muốn sơ đồ, sau đó chạy macro.
Nếu bạn đã có một sơ đồ thì tôi khuyên bạn nên nhấp vào bên cạnh sơ đồ hiện có, chạy macro, sau đó xóa sơ đồ cũ nếu bạn không còn cần nó nữa.
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
