MS Word + VBA + RegExp: Вземете номер на страница за съвпадение

Мисля, че това вероятно пасва по-добре на SuperUser.

Отговорът на въпроса е „да“.

Selection.Information(wdActiveEndAdjustedPageNumber)

Горното свойство във VBA ще ви даде номера на страницата на селекция.

Освен това VBA може да свърши известна работа с регулярни изрази.

Това се оказа доста сложно и не мога да кажа дали решението ми работи за който и да е документ. Основният проблем е, както е посочено във въпроса, че RegexMatch.FirstIndex не може да се използва за определяне дали действителното съвпадение е в документа на MS Word. Това се дължи на факта, че съпоставянето на регулярни изрази се извършва на свойство range.Text (String) и този низ просто съдържа различен брой знаци от този на обекта диапазон и следователно индексите не съвпадат.

Така че моето решение е за всяко съвпадение, правя Търсене в целия документ за това съвпадение. методите за намиране дават обект Range, от който може да се определи правилната страница.

В моя специален случай съвпадението може да бъде едно и също нещо и различна стойност. Пример: 343в моя случай ще бъде същото като Prefix-343. Вторият проблем беше, че съвпаденията трябва да бъдат сортирани, напр. 123преди 324независимо кое от тях се среща първо в документа.

Ако се нуждаете от функцията за сортиране, ще ви трябва и следното за „модули“:

Функция SortDictionary:

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

Модул "modQSortInPlace":

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

Ако не е необходимо сортиране, нямате нужда от тях, но трябва да премахнете съответното извикване на функция SortDictionary Dict, Trueот моя код.

Сега към моя код. Някои части можете да премахнете, особено тази за форматиране. Това е специфично за моя случай. Също така, ако вашето съвпадение е "уникално", напр. не е префикс или така че можете също да опростите кода. Ще трябва да направите справка в „Библиотеката за скриптове на 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