title: Extract Headings and Pagenumber of Table of Contents of a Word Document with VBA
body: <p>Basically what we have here </p>
  
  <p><a href="https://stackoverflow.com/questions/274814/getting-the-headings-from-a-word-document">Getting the headings from a Word document</a></p>
  
  <pre><code>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 &amp; vbNewLine
  
          ' Set the style of the selected range and
          ' then collapse the range for the next entry.
          rng.Style = "Heading " &amp; 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
  </code></pre>
  
  <p>but I need the page number for each heading too.</p>
  
  <p>I tried doing a search for each heading, select the search result and retrieve the wdActiveEndPageNumber.</p>
  
  <p>This didn't work, was slow and is sure an ugly approach.</p>
  
  <p>I'd like to paste the found stuff into another word document like:
  rng.InsertAfter "Page: " &amp; pageNum &amp; " Header: " &amp; strText &amp; vbNewLine</p>