(Hinweis: Lösung siehe unten.)

Ich habe versucht, die Seitenzahlen mithilfe von VBA von Seiten abzurufen, auf denen sich verschiedene Überschriften in einem Word-Dokument befinden. Mein aktueller Code gibt entweder 2 oder 3 und nicht die korrekt zugeordneten Seitenzahlen zurück, je nachdem, wo und wie ich ihn in meinem Haupt-Sub verwende.

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 ist ein Testdokument, das ich mit 10 Überschriften auf 3 Seiten erstellt habe. Ich habe die Überschriften aus dem Internet abgerufengetCrossReferenceItems Methode später in meinem Code verwendet.

Was ich versuche, ist die Ergebnisse aus der Schleife durchgetCrossReferenceItems Methode und verwenden Sie sie jeweils in einem Find-Objekt aufdocSource und daraus ersehen, auf welcher Seite sich das Ergebnis befindet. Die Seitenzahlen werden dann später in meinem Code in einer Zeichenfolge verwendet. Diese Zeichenfolge plus Seitenzahl wird zu einem anderen Dokument hinzugefügt, das am Anfang meiner Hauptuntergruppe erstellt wird. Alles andere ist ein Vergnügen, außer dieses Codesegment.

Idealerweise muss dieses Segment ein zweites Array mit den zugehörigen Seitenzahlen aus jedem Suchergebnis füllen.

Probleme gelöst

Danke Kevin, du warst hier eine große Hilfe, ich habe jetzt genau das, was ich von der Ausgabe dieser braucheSub.

docSource ist ein Testdokument, das ich mit 10 Überschriften auf 3 Seiten erstellt habe. docOutline ist ein neues Dokument, das als Inhaltsverzeichnis dient.

Ich musste das benutzenSub über die integrierten Inhaltsverzeichnisfunktionen von Word, weil:

Ich habe mehrere Dokumente einzuschließen, ich könnte das verwendenRD Feld, um diese aber einzuschließen

Ich habe ein anderesSub Dadurch wird eine benutzerdefinierte dezimale Seitennummerierung in jedem Dokument 0.0.0 (Kapitel.Abschnitt.Seite) generiert, die als Seitennummern in das Inhaltsverzeichnis aufgenommen werden muss, damit das gesamte Dokumentpaket Sinn macht. Es gibt wahrscheinlich eine andere Möglichkeit, dies zu tun, aber ich habe die integrierten Funktionen von Word nicht verstanden.

Dies wird eine Funktion, die in meine Seitennummerierung aufgenommen wirdSub. Ich bin derzeit zu 3/4 auf dem Weg, dieses kleine Projekt abzuschließen, das letzte Quartal sollte unkompliziert sein.

Überarbeiteter und bereinigter endgültiger 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

Dieser Code wird jetzt produziert (was es laut meiner Überschriften-Spezifikation in test-doc.docx sein sollte):

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

Dazu habe ich das gelöstActiveDocument Wechsel Problem mitdocSource.select unddocOutline.Select Anweisungen anstelle von.Active.

Nochmals vielen Dank Kevin, sehr geschätzt :-)

Phil