vba - vba: 配列のテキストを使用して selection.find からページ番号を返す

Question

(注: 解決策については、以下を参照してください。)

VBA を使用して、Word 文書のさまざまな見出しが存在するページからページ番号を取得しようとしています。私の現在のコードは、メインのサブで使用する場所と方法に応じて、正しく関連付けられたページ番号ではなく、2 または 3 を返します。

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メソッドからの結果をループし、それぞれを Find オブジェクトで使用してdocSource、結果がどのページにあるかを確認することです。ページ番号は、後でコードの文字列で使用されます。この文字列とページ番号は、メインサブの先頭に作成される別のドキュメントに追加されます。このコードセグメント以外はすべて正常に機能します。

理想的には、このセグメントで行う必要があるのは、各検索結果から関連するページ番号を 2 番目の配列に入力することです。

解決した問題

ここで大いに助けてくれたケビンに感謝しますSub。

docSource は、3 ページにわたって 10 個の見出しを設定したテストドキュメントです。docOutline は、目次ドキュメントとして機能する新しいドキュメントです。

Sub次の理由により、Word の組み込みの目次機能よりもこれを使用する必要がありました。

含めるドキュメントが複数あるので、RDフィールドを使用してこれらを含めることができますが、
Sub私は、ドキュメントパッケージ全体を意味のあるものにするために、ページ番号として TOC に含める必要がある、各ドキュメント 0.0.0 (chapter.section.page の代表) にカスタムの 10 進数のページ番号を生成する別のものを持っています。おそらくこれを行う別の方法がありますが、私は 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

これに加えて、の代わりにandステートメントActiveDocumentを使用して切り替えの問題を解決しました。docSource.selectdocOutline.Select.Active

再びケビンに感謝します、大歓迎です:-)

フィル

score 9 · Accepted Answer

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。これらは、以前の提案の問題の根本原因であると思います。最初の実行以外の実行時に検索がラップされなかったため、選択は最終ページに設定されます。

vba - vba: 配列のテキストを使用して selection.find からページ番号を返す

1 に答える 1

Related

Reference