リクエストどおり、ここに答えがあります。
解決策:
私はここでコードを使用しました:素晴らしいスタートであったWord 文書から見出しを取得する- VonCに感謝そして、CreateOutline サブルーチンにいくつかの変更を加えました:
Public Sub CreateOutline()
Dim docOutline As Word.Document
Dim docSource As Word.Document
Dim rng As Word.Range
Dim astrHeadings As Variant
Dim strText As String
Dim intLevel As Integer
' ========================================
' Added a static variable to retain the
' last paragraph outline level
' ========================================
Static intLastLevel As Integer
' ========================================
Dim intItem As Integer
Set docSource = ActiveDocument
Set docOutline = Documents.Add
' Content returns only the
' main body of the document, not
' the headers and footer.
Set rng = docOutline.Content
astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
For intItem = LBound(astrHeadings) To UBound(astrHeadings)
' Get the text and the level.
strText = Trim$(astrHeadings(intItem))
intLevel = GetLevel(CStr(astrHeadings(intItem)))
' ========================================
' If the paragraph level is increasing, add a tab,
' if decreasing add a new line, and insert the appropriate
' tabs as prefix.
' ========================================
If intLevel > intLastLevel Then
strText = vbTab & strText
Else
strText = vbNewLine & String(intLevel, Chr(9)) & strText
End If
' ========================================
' Add the text to the document.
rng.InsertAfter strText
' Set the style of the selected range and
' then collapse the range for the next entry.
' rng.Style = "Heading " & intLevel ' Removed the style setting
' ========================================
' Remeber the current paragraph level
' ========================================
intLastLevel = intLevel
rng.Collapse wdCollapseEnd
Next intItem
End Sub
Private Function GetLevel(strItem As String) As Integer
' Return the heading level of a header from the
' array returned by Word.
' The number of leading spaces indicates the
' outline level (2 spaces per level: H1 has
' 0 spaces, H2 has 2 spaces, H3 has 4 spaces.
Dim strTemp As String
Dim strOriginal As String
Dim intDiff As Integer
' Get rid of all trailing spaces.
strOriginal = RTrim$(strItem)
' Trim leading spaces, and then compare with
' the original.
strTemp = LTrim$(strOriginal)
' Subtract to find the number of
' leading spaces in the original string.
intDiff = Len(strOriginal) - Len(strTemp)
GetLevel = (intDiff / 2) + 1
End Function
次に、新しいドキュメントの出力全体を強調表示し、それを表に変換しました。私が抱えていた唯一の問題は、修正が簡単な「空白」の最初の列であり、ヘッダーに必要なフォーマットを追加しました。
他の人がこれが役立つことを願っています。