Export Document Headings Outline

Attribute VB_Name = "ExportHeadingsOutline"
Option Explicit

Public Sub ExportHeadingsOutline()
    Dim doc As Document
    Dim para As Paragraph
    Dim outPath As String
    Dim fileNum As Integer
    Dim styleName As String
    Dim level As Integer

    Set doc = ActiveDocument
    outPath = doc.Path & Application.PathSeparator & "Outline_" & Format(Now, "yyyymmdd-hhnnss") & ".txt"

    fileNum = FreeFile
    Open outPath For Output As #fileNum

    For Each para In doc.Paragraphs
        styleName = para.Style
        If InStr(1, styleName, "Heading") = 1 Then
            level = 0
            On Error Resume Next
            level = CInt(Mid(styleName, 8))
            On Error GoTo 0
            Print #fileNum, Space((level - 1) * 2) & Trim(para.Range.Text)
        End If
    Next para

    Close #fileNum
    MsgBox "Outline exported to:" & vbCrLf & outPath, vbInformation
End Sub