Word Document : List of Heading with associated next paragraph (for executive summary list)

Question

I refer to the link below which offers a very good solution [ using GetCrossReferenceItems(wdRefTypeHeading) ] to generate a list of all headings in the document.

However, I would like to take this a step further and include the first paragraph following each heading in the sumamry table. The intended use is to give the reader an overview of what is included under each heading.

Many thanx.

================================= Link to "heading only" solution : http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document

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
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)))

    ' Add the text to the document.
    rng.InsertAfter strText & vbNewLine

    ' Set the style of the selected range and
    ' then collapse the range for the next entry.
    rng.Style = "Heading " & 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