title: vba: return page number from selection.find using text from array
body: <p>(Note: See below for solution.)</p>
  
  <p>I have been trying to retrieve the page numbers from pages that various headings reside on in a word document using VBA.  My current code returns either 2 or 3, and not the correctly associated page numbers, depending on where and how I use it in my main Sub.</p>
  
  <pre><code>astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)
  
  For Each hds In astrHeadings
          docSource.Activate
          With Selection.Find
              .Text = Trim$(hds)
              .Forward = True
              MsgBox hds &amp; ":" &amp; Selection.Information(wdActiveEndPageNumber), vbOKOnly
          End With
          Selection.Find.Execute
  Next
  </code></pre>
  
  <p><code>docSource</code> is a test document I have set up with 10 headings over 3 pages. I have the headings retrieved from the <code>getCrossReferenceItems</code> method in use later in my code.</p>
  
  <p>What I am attempting is to loop through the results from the <code>getCrossReferenceItems</code> method and use each them in a Find object on <code>docSource</code> and from this ascertain what page the result is on. The page numbers will then be used in a string later in my code. This string plus page number will be added to another document which is created at the beginning of my main sub, everything else works a treat but this code segment.</p>
  
  <p>Ideally what I need this segment to do is fill a second array with the associated page numbers from each Find result.</p>
  
  <p><strong>Problems Solved</strong></p>
  
  <p>Thanks Kevin you have been a great help here, I now have exactly what I need from the output of this <code>Sub</code>. </p>
  
  <p>docSource is a test document I have set up with 10 headings over 3 pages. 
  docOutline is a new document which will act as a Table of Contents document. </p>
  
  <p>I have had to use this <code>Sub</code> over Word's built-in TOC features because: </p>
  
  <ol>
  <li><p>I have multiple documents to include, I could use the <code>RD</code> field to include these but </p></li>
  <li><p>I have another <code>Sub</code> which generates custom decimal page numbering in each document 0.0.0 (chapter.section.page representative) that, for the whole document package to make sense, need to be included in the TOC as page numbers. There probably is another way of doing this but I came up blank with Word's built-in features.</p></li>
  </ol>
  
  <p>This will become a Function to be included in my page numbering <code>Sub</code>. I am currently 3/4 of the way to completing this little project, the last quarter should be straightforward. </p>
  
  <p><strong>Revised and cleaned final Code</strong></p>
  
  <pre><code>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 &lt;= minLevel Then
                  If intLevel = "1" Then
                      strText = " " &amp; Trim$(astrHeadings(intItem)) &amp; vbTab &amp; "1" &amp; "." &amp; "2" &amp; "." &amp; strFootNum(intItem) &amp; vbCr
                  End If
                  If intLevel = "2" Then
                      strText = "   " &amp; Trim$(astrHeadings(intItem)) &amp; vbTab &amp; "1" &amp; "." &amp; "2" &amp; "." &amp; strFootNum(intItem) &amp; vbCr
                  End If
                  If intLevel = "3" Then
                      strText = "      " &amp; Trim$(astrHeadings(intItem)) &amp; vbTab &amp; "1" &amp; "." &amp; "2" &amp; "." &amp; strFootNum(intItem) &amp; vbCr
                  End If
                  If intLevel = "4" Then
                      strText = "         " &amp; Trim$(astrHeadings(intItem)) &amp; vbTab &amp; "1" &amp; "." &amp; "2" &amp; "." &amp; strFootNum(intItem) &amp; vbCr
                  End If
                  If intLevel = "5" Then
                      strText = "            " &amp; Trim$(astrHeadings(intItem)) &amp; vbTab &amp; "1" &amp; "." &amp; "2" &amp; "." &amp; strFootNum(intItem) &amp; vbCr
                  End If
              ' Add the text to the document.
              rng.InsertAfter strText &amp; 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
  </code></pre>
  
  <p>This code is now producing (What it should be according to my headings specification found in test-doc.docx):</p>
  
  <pre><code>This is heading one                  1.2.1
    This is heading two                1.2.1
      This is heading two.one          1.2.1
      This is heading two.three        1.2.1
  This is heading one.two              1.2.2
       This is heading three           1.2.2
          This is heading four         1.2.2
             This is heading five      1.2.2
             This is heading five.one  1.2.3
             This is heading five.two  1.2.3
  </code></pre>
  
  <p>In Addition to this I have solved the <code>ActiveDocument</code> switching issue by using  <code>docSource.select</code> and <code>docOutline.Select</code> statements instead of using<code>.Active</code>.</p>
  
  <p>Thanks again Kevin, greatly appreciated :-)</p>
  
  <p>Phil</p>