Getting the headings from a Word document

Question

How do I get a list of all the headings in a word document by using VBA?

Answer 1

You mean like this createOutline function (which actually copy all headings from a source word document into a new word document):

(I believe the astrHeadings = _docSource.GetCrossReferenceItems(wdRefTypeHeading) function is the key in this program, and should allow you to retrieve what you are asking for)

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

Answer 2

The easiest way to get a list of headings, is to loop through the paragraphs in the document, for example:

 Sub ReadPara()

    Dim DocPara As Paragraph

    For Each DocPara In ActiveDocument.Paragraphs

     If Left(DocPara.Range.Style, Len("Heading")) = "Heading" Then

       Debug.Print DocPara.Range.Text

     End If

    Next


End Sub

By the way, I find it is a good idea to remove the final character of the paragraph range. Otherwise, if you send the string to a message box or a document, Word displays an extra control character. For example:

Left(DocPara.Range.Text, len(DocPara.Range.Text)-1)

Answer 3

Wow - VonC... your solution to the the above problem assisted me greatly.

I am looking for a similar solution... but require the next step of including the first paragraph following each heading to make an "executive summary sheet.

How can I retrieve/reference the paragraph following each heading?

Any pointers greatly appreciated.

Answer 4

Here is a working example using Aspose.Words

http://www.aspose.com/documentation/.net-components/aspose.words-for-.net-and-java/howto-extract-content-based-on-styles.html

It shows how to extract text and paragraphs formatted with certain styles. To extract headings you need to extract paragraphs formatted with styles Heading 1 to Heading 9.