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

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 上的 Find 对象中使用它们并由此确定结果在哪个页面上。页码稍后将在我的代码中用于字符串。这个字符串加上页码将被添加到另一个文档中，该文档在我的主子文件的开头创建，除此代码段外，其他一切都可以正常工作。

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

问题解决

谢谢凯文，你在这里帮了很大的忙，我现在从这个 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)将符合要求，尽管它目前位于您代码的错误位置。执行查找后放置此行，如下所示:

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线条 - 我认为这些是我之前建议的问题根源。选择将设置为最后一页，因为除了第一次运行之外，该查找不会在任何运行中结束。