Question

（注意：请参阅下面的解决方案。）

我一直在尝试使用VBA从word文档中的各种标题页面中检索页码。我当前的代码返回2或3，而不是正确关联的页码，具体取决于我在主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是我设置的测试文档，有3个页面的10个标题。我从我的代码中稍后使用的getCrossReferenceItems方法中检索了标题。

我尝试的是循环遍历getCrossReferenceItems方法的结果，并在docSource上的查找对象中使用它们，并从中确定结果所在的页面。然后，我的代码中的页码将在稍后的字符串中使用。这个字符串加上页码将被添加到另一个在我的主子开头创建的文档中，其他所有文件都可以用来处理这个代码段。

理想情况下，我需要这个片段来填充第二个数组，其中包含每个查找结果中的相关页码。

解决的问题

谢谢Kevin，你在这里得到了很大的帮助，我现在已经从Sub的输出得到了我需要的东西。

docSource是我设置的测试文档，有3个页面的10个标题。 docOutline是一个新文档，它将作为目录文档。

我必须使用此Sub而不是Word的内置TOC功能，因为：

我要包含多个文档，我可以使用RD字段来包含这些文件，但
我有另一个Sub，它在每个文件0.0.0（chapter.section.page代表）中生成自定义小数页编号，对于整个文档包来说有意义，需要包含在TOC作为页码。可能还有另一种方法可以做到这一点，但我对Word的内置功能感到茫然。

这将成为我的页面编号Sub中包含的功能。我现在是完成这个小项目的3/4，最后一个季度应该是直截了当的。

修改并清理了最终代码

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

此代码正在生成（根据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

除此之外，我还使用ActiveDocument和docSource.select语句而不是docOutline.Select解决了.Active转换问题。

再次感谢凯文，非常感谢： - ）

菲尔

Answer 1

看起来Selection.Information(wdActiveEndPageNumber)符合帐单，尽管它目前在您的代码中处于错误的位置。执行find之后放下这一行，如下所示：

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

新问题的补充：

当您设置strFooter值时，当您使用ReDim时，您正在使用ReDim Preserve调整数组大小：

ReDim Preserve strFootNum(1 To UBound(astrHeadings))

但是，除非UBound(astrHeadings)在For循环中发生变化，否则最佳做法是将ReDim语句拉出循环：

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

作为参考，ReDim语句将数组中的所有项设置回0，而ReDim Preserve在调整数组大小之前保留数组中的所有数据。

另请注意Selection.Move和.Wrap = wdFindContinue行 - 我认为这些是我之前建议的问题的根源。选择将被设置为最终页面，因为除了第一次运行之外，查找没有包装在除此之外的任何运行中。

vba：使用array中的文本从selection.find返回页码

1 个答案: