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

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

提问by Phil Clayton

(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.

我一直在尝试从使用 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

docSourceis a test document I have set up with 10 headings over 3 pages. I have the headings retrieved from the getCrossReferenceItemsmethod in use later in my code.

docSource是我在 3 页上设置了 10 个标题的测试文档。我从getCrossReferenceItems稍后在我的代码中使用的方法中检索了标题。

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

我正在尝试的是遍历该getCrossReferenceItems方法的结果，并在 Find 对象中使用它们，docSource并从中确定结果在哪个页面上。页码稍后将在我的代码中用于字符串。这个字符串加上页码将被添加到另一个文档中，该文档在我的主子文件的开头创建，除此代码段外，其他一切都可以正常工作。

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

理想情况下，我需要此段做的是用每个 Find 结果中的关联页码填充第二个数组。

Problems Solved

解决的问题

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

谢谢凯文，你在这里提供了很大的帮助，我现在从这个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.

docSource 是一个测试文档，我在 3 页上设置了 10 个标题。docOutline 是一个新文档，它将充当目录文档。

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

我不得不Sub在 Word 的内置 TOC 功能上使用它，因为：

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

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

1. 我有多个文档要包含，我可以使用该RD字段来包含这些但是

2. 我有另一个Sub在每个文档 0.0.0（chapter.section.page 代表）中生成自定义十进制页码，为了使整个文档包有意义，需要作为页码包含在 TOC 中。可能还有另一种方法可以做到这一点，但我对 Word 的内置功能一无所知。

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.

这将成为包含在我的页码中的函数Sub。我目前已经完成这个小项目的 3/4，最后一个季度应该很简单。

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):

此代码现在正在生成（根据我在 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 ActiveDocumentswitching issue by using docSource.selectand docOutline.Selectstatements instead of using.Active.

除此之外，我ActiveDocument通过使用docSource.selectanddocOutline.Select语句而不是 using解决了切换问题 .Active。

Thanks again Kevin, greatly appreciated :-)

再次感谢凯文，非常感谢:-)

Phil

菲尔

回答by Kevin Pope

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:

它看起来Selection.Information(wdActiveEndPageNumber)符合要求，尽管它目前位于您代码的错误位置。执行查找后放置此行，如下所示：

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 ReDimto resize the array when you should be using ReDim Preserve:

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

ReDim Preserve strFootNum(1 To UBound(astrHeadings))

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

但是，除非在有问题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

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

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

Also note the Selection.Moveand the .Wrap = wdFindContinuelines - 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.

还要注意线条Selection.Move和.Wrap = wdFindContinue线条 - 我认为这些是我之前建议的问题根源。选择将设置为最后一页，因为除了第一次运行之外，该查找不会在任何运行中结束。