vba: return page number from selection.find using text from array

Question

(Note: See below for solution.)

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.

astrHeadings = docSource.GetCrossReferenceItems(wdRefTypeHeading)

For Each hds In astrHeadings
        docSource.Activate
        With Selection.Find
            .Text = Trim$(hds)
            .Forward = True
            MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly
        End With
        Selection.Find.Execute
Next

docSource is a test document I have set up with 10 headings over 3 pages. I have the headings retrieved from the getCrossReferenceItems method in use later in my code.

What I am attempting is to loop through the results from the getCrossReferenceItems method and use each them in a Find object on docSource 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.

Ideally what I need this segment to do is fill a second array with the associated page numbers from each Find result.

Problems Solved

Thanks Kevin you have been a great help here, I now have exactly what I need from the output of this Sub.

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.

I have had to use this Sub over Word's built-in TOC features because:

1. I have multiple documents to include, I could use the RD field to include these but

2. I have another Sub 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.

This will become a Function to be included in my page numbering Sub. I am currently 3/4 of the way to completing this little project, the last quarter should be straightforward.

Revised and cleaned final 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 <= 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

This code is now producing (What it should be according to my headings specification found in test-doc.docx):

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

In Addition to this I have solved the ActiveDocument switching issue by using docSource.select and docOutline.Select statements instead of using.Active.

Thanks again Kevin, greatly appreciated :-)

Phil

Answer 1

It looks like Selection.Information(wdActiveEndPageNumber) will fit the bill, although it's in the wrong point of your code currently. Put this line after you execute the find, like so:

For Each hds In astrHeadings
    docSource.Activate
    With Selection.Find
        .Text = Trim$(hds)
        .Forward = True
    End With
    Selection.Find.Execute
    MsgBox hds & ":" & Selection.Information(wdActiveEndPageNumber), vbOKOnly
Next

Addition for new question:

When you're setting the strFooter values, you're using ReDim to resize the array when you should be using ReDim Preserve:

ReDim Preserve strFootNum(1 To UBound(astrHeadings))

But, unless UBound(astrHeadings) is changing during the For loop in question, it'd probably be best practice to pull the ReDim statement outside of the loop:

ReDim strFootNum(0 To UBound(astrHeadings))
For i = 0 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
        strFootNum(i) = 0 'Or whatever you want to do if it's not found'
    End If
    Selection.Move  
Next

For reference, the ReDim statement sets all the items in an array back to 0, whereas ReDim Preserve preserves all the data in the array before you resize it.

Also note the Selection.Move and the .Wrap = wdFindContinue lines - I think these were the root of the issue with my previous suggestions. The selection would be set to the final page because the find wasn't wrapping on any run of this other than the first run.