MS Word + VBA + RegExp: получить номер страницы соответствия

Я думаю, что это, вероятно, лучше подходит для SuperUser.

Ответ на вопрос «да».

Selection.Information(wdActiveEndAdjustedPageNumber)

Вышеупомянутое свойство в VBA даст вам номер страницы выбора.

Кроме того, VBA может выполнять некоторую работу с регулярными выражениями.

Это оказалось довольно сложным, и я не могу сказать, работает ли мое решение для любого документа. Основная проблема, как указано в Вопросе, заключается в том, что RegexMatch.FirstIndex нельзя использовать для определения того, действительно ли совпадение находится в документе MS Word. Это связано с тем, что сопоставление регулярных выражений выполняется для свойства range.Text (String), и эта строка просто содержит другое количество символов, чем объект диапазона, и, следовательно, индексы не совпадают.

Итак, мое решение для каждого совпадения, я делаю поиск во всем документе для этого совпадения. методы find дают объект Range, из которого можно определить правильную страницу.

В моем особом случае совпадение может быть одним и тем же, но с другим значением. Пример: 343 в моем случае будет таким же, как Prefix-343. Вторая проблема заключалась в том, что совпадения должны быть отсортированы, например, 123перед 324независимо от того, какое из совпадений встречается первым в документе.

Если вам требуется функция сортировки, вам также понадобятся следующие «модули»:

Функция словаря сортировки:

http://www.cpearson.com/excel/CollectionsAndDictionaries.htm

Модуль "modQSortInPlace":

http://www.cpearson.com/Zips/modQSortInPlace.zip

Если сортировка не нужна, они вам не нужны, но вам нужно удалить соответствующий вызов функции SortDictionary Dict, True из моего кода.

Теперь к моему коду. Части Soem можно удалить, особенно форматирование. Это конкретно для моего случая. Также, если ваш матч «уникальный», например. не префикс, или поэтому вы также можете упростить код. Вам нужно будет сослаться на «Библиотеку сценариев Microsoft».

Option Explicit

Sub ExtractRNumbers()

    Dim Dict As Scripting.Dictionary
    Set Dict = CreateObject("Scripting.dictionary")

    Dim regExp, Match, Matches
    Dim rNumber As String
    Dim range As range

    Set regExp = CreateObject("VBScript.RegExp")
    regExp.Pattern = "\b(R-)?\d{2}-\d{4,5}(-\d)?\b"
    regExp.IgnoreCase = False
    regExp.Global = True

    ' determine main section, only extract R-Numbers from main section
    ' and not the Table of contents as example
    ' main section = section with most characters

    Dim section As section
    Dim maxSectionSize As Long
    Dim sectionSize As Long
    Dim sectionIndex As Integer
    Dim currentIndex As Integer
    maxSectionSize = 0
    currentIndex = 1
    For Each section In ActiveDocument.Sections
        sectionSize = Len(section.range.text)
        If sectionSize > maxSectionSize Then
            maxSectionSize = sectionSize
            sectionIndex = currentIndex
        End If
        currentIndex = currentIndex + 1
    Next


    Set Matches = regExp.Execute(ActiveDocument.Sections(sectionIndex).range.text)


    For Each Match In Matches

        ' If the Document contains Tables, ActiveDocument.range.Text will contain
        ' BEL charachters (chr(7)) that probably define the table structure. The issue
        ' is that then Match.FirstIndex does not point to the actual first charachter
        ' of a Match in the Document.
        ' Also there are other things (unknwon) that lead to the same issue, eg.
        ' Match.FirstIndex can not be used to find the actual "matching word" within the
        ' document. Because of that below commented apporach does not work on a generic document

        '   Set range = ActiveDocument.range(Match.FirstIndex, Match.FirstIndex + Len(Match.Value))
        '   page = range.Information(wdActiveEndAdjustedPageNumber)

        ' Maybe there is a simpler solution but this works more or less
        ' the exception beign tables again. see http://support.microsoft.com/kb/274003

        ' After a match is found the whole document is searched using the find method.
        ' For each find result the page number is put into an array (if it is not in the array yet)
        ' Then the match is formatted properly.
        ' After formatting, it is checked if the match was previously already found
        '
        '   If not, we add a new entry to the dictionary (key = formatted match, value = array of page numbers)
        '
        '   If match was already found before (but potentially in a different format! eg R-87-1000 vs 87-1000 as example),
        '   all additional pages are added to the already found pages.

        Set range = ActiveDocument.Sections(sectionIndex).range
        With range.Find
            .text = Match.Value
            .MatchWholeWord = True
            .MatchCase = True
            .Wrap = wdFindStop
        End With

        Dim page As Variant
        Dim pages() As Integer
        Dim index As Integer
        index = 0
        ReDim pages(0)

        Do While range.Find.Execute() = True
            page = range.Information(wdActiveEndAdjustedPageNumber)
            If Not IsInArray(page, pages) Then
                ReDim Preserve pages(index)
                pages(index) = page
                index = index + 1
            End If
        Loop

        ' FORMAT TO PROPER R-NUMBER: This is specific to my case
        rNumber = Match.Value
        If Not rNumber Like "R-*" Then
         rNumber = "R-" & rNumber
        End If
        ' remove possible batch number as r-number
        If Len(rNumber) > 11 Then
            rNumber = Left(rNumber, Len(rNumber) - 2)
        End If
        ' END FORMAT

        If Not Dict.Exists(rNumber) Then
            Dict.Add rNumber, pages
        Else
            Dim existingPages() As Integer
            existingPages = Dict(rNumber)
            For Each page In pages
                If Not IsInArray(page, existingPages) Then
                    ' add additonal pages. this means that the previous match
                    ' was formatted different, eg R-87-1000 vs 87-1000 as example
                    ReDim Preserve existingPages(UBound(existingPages) + 1)
                    existingPages(UBound(existingPages)) = page
                    Dict(rNumber) = existingPages
                End If
            Next
        End If

    Next
    'sort dictionary by key (R-Number)
    SortDictionary Dict, True
    Dim fso
    Set fso = CreateObject("Scripting.FileSystemObject")

    Dim stream
    ' Create a TextStream.
    Set stream = fso.CreateTextFile(ActiveDocument.Path & "\" & ActiveDocument.Name & "-rNumbers.txt", True)

    Dim key As Variant
    Dim output As String
    Dim i As Integer
    For Each key In Dict.Keys()
        output = key & vbTab
        pages = Dict(key)
        For i = LBound(pages) To UBound(pages)
            output = output & pages(i) & ", "
        Next
        output = Left(output, Len(output) - 2)
        stream.WriteLine output        
    Next
    Set Dict = Nothing
    stream.Close
End Sub

Private Function IsInArray(page As Variant, pages As Variant) As Boolean
    Dim i As Integer
    IsInArray = False
    For i = LBound(pages) To UBound(pages)
        If pages(i) = page Then
            IsInArray = True
            Exit For
        End If
    Next
End Function