(Nota: ver más abajo para la solución.)

He estado tratando de recuperar los números de página de páginas en las que se encuentran varios encabezados en un documento de Word usando VBA. Mi código actual devuelve 2 o 3, y no los números de página correctamente asociados, dependiendo de dónde y cómo lo uso en mi Sub principal.

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 es un documento de prueba que he creado con 10 encabezados en 3 páginas. Tengo los encabezados recuperados de lagetCrossReferenceItems Método en uso más adelante en mi código.

Lo que estoy intentando es recorrer los resultados de lagetCrossReferenceItems Método y utilizar cada uno de ellos en un objeto Buscar endocSource y a partir de esta página, determinar en qué página está el resultado. Los números de página se utilizarán en una cadena más adelante en mi código. Esta cadena y el número de la página se agregarán a otro documento que se creó al principio de mi subcomité principal, todo lo demás funciona bien, pero este segmento de código.

Idealmente, lo que necesito para este segmento es llenar una segunda matriz con los números de página asociados de cada resultado de Búsqueda.

Problemas resueltos

Gracias Kevin, has sido de gran ayuda aquí, ahora tengo exactamente lo que necesito de la salida de esteSub.

docSource es un documento de prueba que he configurado con 10 encabezados en 3 páginas. docOutline es un nuevo documento que actuará como un documento de tabla de contenido.

He tenido que usar estoSub sobre las características TOC integradas de Word porque:

Tengo varios documentos para incluir, podría usar elRD campo para incluir estos pero

Tengo otroSub que genera una numeración de páginas decimales personalizada en cada documento 0.0.0 (capítulo. sección. representante de página) que, para que todo el paquete de documentos tenga sentido, debe incluirse en la tabla de contenido como números de página. Probablemente hay otra forma de hacer esto, pero me quedé en blanco con las características integradas de Word.

Esto se convertirá en una función que se incluirá en la numeración de mi página.Sub. Actualmente tengo 3/4 del camino para completar este pequeño proyecto, el último trimestre debería ser sencillo.

Código final revisado y limpiado.

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

Este código ahora está produciendo (lo que debería estar de acuerdo con la especificación de mis encabezados que se encuentra en 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

Además de esto he resuelto elActiveDocument cambio de problema mediante el uso dedocSource.select ydocOutline.Select declaraciones en lugar de usar.Active.

Gracias de nuevo Kevin, muy apreciado :-)

Phil