Printing Document Headings

Creates a new document with Heading XX style paragraphs from the active document

Public Sub PrintHeadings 
Dim objParagraph As Paragraph 
Dim objRange As Range 
Dim objDocumentA As Document 
Dim objDocumentB As Document 
Dim iLevel As Integer 
Dim iMaxLevel As Integer 

iMaxLevel = InputBox("Enter Maximum level for Heading style: ") 
If (iMaxLevel = 0) Then Exit Sub 

Set objDocumentA = Application.ActiveDocument 
Set objDocumentB = Documents.Add(objDocumentA.AttachedTemplate.Name) 
With objDocumentB.PageSetup 
   .TopMargin - InchesToPoints(0.25) 
   .BottomMargin - InchesToPoints(0.25) 
   .LeftMargin - InchesToPoints(0.25) 
   .RightMargin - InchesToPoints(0.25) 
End With 

Set objRange = objDocumentB.Range 
For Each objParagraph In objDocumentA.Paragraphs 
   iLevel = 0 
   If objParagraph.Format.Style Like "Heading [0-9]" Then 
      iLevel = Val(Mid(objParagraph.Format.Style,8)) 
      If (iLevel > 0) And (iLevel <- iMaxLevel) Then 
         objRange.Collapse wdCollapseDirection.wdCollapseEnd 
         objRange.Text = String(iLevel - 1), vbTab) & Format(iLevel) & ") " & objParagraph.Range.Text 
     End If 

' delete any annoying page breaks
   Selection.Find.ClearFormatting 
   Selection.Find.Replacement.ClearFormatting 
   With Selection.Find 
      .Text = "^m" 
      .Replacement.Text = "" 
      .Forward = True 
   End With 
   Selection.Find.Execute Replace:=wdReplace.wdReplaceAll 
End Sub