Public Sub CreateOutline()

' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document

    Dim docOutline As Word.Document

    Dim docSource As Word.Document

    Dim rng As Word.Range

    Dim strFootNum() As Integer

    Dim astrHeadings As Variant

    Dim strText As String

    Dim intLevel As Integer

    Dim intItem As Integer

    Dim minLevel As Integer

    Dim tabStops As Variant

​

    Set docSource = ActiveDocument

    Set docOutline = Documents.Add

​

    minLevel = 5  'levels above this value won't be copied.

​

    ' Content returns only the

    ' main body of the document, not

    ' the headers and footer.

    Set rng = docOutline.Content

    astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)

​

    docSource.Select

    ReDim strFootNum(0 To UBound(astrHeadings))

    For i = 1 To UBound(astrHeadings)

        With Selection.Find

            .Text = Trim(astrHeadings(i))

            .Wrap = wdFindContinue

        End With

​

        If Selection.Find.Execute = True Then

            strFootNum(i) = Selection.Information(wdActiveEndPageNumber)

        Else

            MsgBox "No selection found", vbOKOnly

        End If

        Selection.Move

    Next

​

    docOutline.Select

​

    With Selection.Paragraphs.tabStops

        '.Add Position:=InchesToPoints(2), Alignment:=wdAlignTabLeft

        .Add Position:=InchesToPoints(6), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots

    End With

​

    For intItem = LBound(astrHeadings) To UBound(astrHeadings)

        ' Get the text and the level.

        ' strText = Trim$(astrHeadings(intItem))

        intLevel = GetLevel(CStr(astrHeadings(intItem)))

        ' Test which heading is selected and indent accordingly

        If intLevel <= minLevel Then

                If intLevel = "1" Then

                    strText = " " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr

                End If

                If intLevel = "2" Then

                    strText = "   " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr

                End If

                If intLevel = "3" Then

                    strText = "      " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr

                End If

                If intLevel = "4" Then

                    strText = "         " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr

                End If

                If intLevel = "5" Then

                    strText = "            " & Trim$(astrHeadings(intItem)) & vbTab & "1" & "." & "2" & "." & strFootNum(intItem) & vbCr

                End If

            ' Add the text to the document.

            rng.InsertAfter strText & vbLf

            docOutline.SelectAllEditableRanges

            ' tab stop to set at 15.24 cm

            'With Selection.Paragraphs.tabStops

            '    .Add Position:=InchesToPoints(6), _

            '    Leader:=wdTabLeaderDots, Alignment:=wdAlignTabRight

            '    .Add Position:=InchesToPoints(2), Alignment:=wdAlignTabCenter

            'End With

            rng.Collapse wdCollapseEnd

        End If

    Next intItem

End Sub

​

Private Function GetLevel(strItem As String) As Integer

    ' from http://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document

    ' 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