vba:使用array中的文本从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结果中的相关页码填充第二个数组.

解决问题

谢谢凯文,你在这里得到了很大的帮助,我现在已经从我的输出中得到了我所需要的Sub.

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

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

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

2. 我有另一个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行 - 我认为这些是我之前建议的问题的根源.选择将设置为最终页面,因为除了第一次运行之外,查找不会包装在除此之外的任何运行上.