Range.Find - проблема с .Found в wdInFieldResult

Question

сокращенного поиск

Когда findRng.Find успешно обнаруживает поисковый текст в поле результата (например, оглавление) начинается следующий .Execute в начале ТОС а не в исходной позиции, которая была указана ниже документа из предыдущего findRng.Find. Это можно визуально показать, выбрав findRng.select. В свойствах Start и End findRng выбор не должен включать начало TOC, но он делает И это похоже на то, что использует метод .Find, потому что он становится адресом Apple Corporate Headquarters; т. е. один бесконечный контур. ;)

Вы можете посмотреть значения findRng.Start и .End, которые ожидаются до утверждения .Execute в нижней части подпрограммы.

Если кто-либо не может исправить проблему сброса диапазона, я был бы счастлив, просто найдя способ быстро определить местоположение .End поля, которое запускает wdInFieldResult, давая True и продолжая жизнь.

Sub findAcronyms() 
     Dim findRng As Range, tempRng As Range 
     Dim oFld As Field 
     Dim findStr As String, acroStr As String 
     Dim acroTbl As Table 
     '################# test code 
     Dim testMode As Boolean 
     Dim testIdx As Long, testSize As Long, i As Long 
     testMode = True 
     testIdx = 0 
     testSize = 25 
     If testMode Then 
      ThisDocument.ShowRevisions = True 
      ThisDocument.TrackRevisions = True 
     End If 
     Quiet (Not testMode) 
     '################# 

     'set acroTbl to ThisDocument's Acronym table 
     Set findRng = ThisDocument.Content 
     findStr = "ACRONYMS" 
     With findRng.Find 
      .ClearFormatting 
      .Style = WdBuiltinStyle.wdStyleHeading1 
      .Text = findStr 
      .Forward = False 
      .Wrap = wdFindStop 
      .Format = False 
      .Execute 
      If Not .Found Then 
       MsgBox findStr & ": not found!", vbExclamation 
       Stop 
       Debug.Print "Debug the issue..." 
      Else 
       findRng.MoveStart wdTable 
       findRng.Expand wdTable 
       Set acroTbl = findRng.Tables(1) 
      End If 
     End With 

     'find occurrences of "(" and if closing parens "(" is within 7 characters then add to end of Acronym table 
     Set findRng = ThisDocument.Content 
     findStr = "(" 
     With findRng.Find 
      .ClearFormatting 
      .Text = findStr 
      .Forward = True 
      .Wrap = wdFindStop 
      .Format = False 
      .Execute 
      Do While .Found 'until Find finds other than itself or EOD 
     '################# test code 
      If testMode Then 
       findRng.Select 
       Debug.Print findRng.Start 
       testIdx = testIdx + 1 
       If testIdx > testSize Then 
        Stop 'and Debug if necessary 
        Exit Sub 
       End If 
      End If 
     '################ 
       i = findRng.MoveEndUntil(")", 7) 
       If i > 2 And Not findRng.Text Like Left(findStr & "#######", _ 
    Len(findRng.Text)) Then 
        'check for pre-existence of acronym before adding to table 
        Set tempRng = ThisDocument.Range(acroTbl.Columns(1).Cells(2).Range.Start, _ 
    acroTbl.Columns(1).Cells(acroTbl.Columns(1).Cells.Count).Range.End) 
        tempRng.Find.ClearFormatting 
        With tempRng.Find 
        .Text = Mid(findRng.Text, 2, i) 
        .Forward = True 
        .Wrap = wdFindStop 
        .Format = False 
        .MatchCase = False 
        .MatchWholeWord = True 
        .MatchWildcards = False 
        .MatchSoundsLike = False 
        .MatchAllWordForms = False 
        .Execute 
        If Not .Found Then 'proceed with adding new acronym to table 
         With acroTbl.Rows 
          .Add 
          With .Last 
           .Cells(1).Range.Text = Mid(findRng.Text, 2, i) 
           i = findRng.Start 
           findRng.Collapse wdCollapseStart 
           findRng.MoveStart wdCharacter, -1 
           findRng.MoveStart wdWord, _ 
    -.Cells(1).Range.Characters.Count 
           .Cells(2).Range.Text = Trim(findRng.Text) 
           findRng.Start = i + 1 
     Debug.Print .Cells(1).Range.Text, .Cells(2).Range.Text 
          End With 
         End With 
        End If 
        End With 
       Else: findRng.MoveStart wdWord 'skip over 2 letter acronyms 
       End If 
       If findRng.Information(wdInFieldResult) Then 
        findRng.MoveStart wdParagraph 'in lieu of a better solution I need to determine how to get out of the field result 
       ElseIf findRng.Information(wdWithInTable) Then 
        If findRng.InRange(findRng.Tables(1).Range.Cells(findRng.Tables(1).Range.Cells.Count).Range) Then 'test if in last cell 
        findRng.Expand wdTable 
        findRng.Collapse wdCollapseEnd 
        Else 
        findRng.MoveStart wdCell 
        End If 
       Else 
        findRng.MoveStart wdWord 
       End If 
     '################# test code 
       If testMode Then findRng.Select 
     '################ 
       findRng.Collapse wdCollapseEnd 
       findRng.End = ThisDocument.Content.End 
       .Execute 
      Loop 
     End With 
     Stop 
     End Sub 

Answer 1

Избегайте нарушенного поведения поля. Результат фактически упростил процедуру. Вместо этого использование Range.MoveStartUntil привело к более простой обработке.

Обычная процедура findAcronyms выполняет поиск этого документа.Content для каждого последующего появления открытых парнеров "(" до тех пор, пока не будет достигнут конец документа. После обнаружения открытых парнеров выполняется несколько тестов фильтрации, чтобы исключить нежелательные результаты, такие как числовые строки и чрезмерная длина аббревиатуры (ограничена 7 символами). В случае успеха акроним сравнивается с существующей сокращенной таблицей для предшествующего существования до добавления с включенными отслеживаемыми изменениями. Множественные формы сокращений (с последним символом = «s») уменьшаются к единственной форме, чтобы снова устранить избыточности.

Наконец, вновь добавленные аббревиатуры прокручиваются на экран, и пользователю предлагается, если они хотят принять и отсортировать таблицу как есть. Затем следует другое приглашение t o выполнить обратную проверку с использованием процедуры checkAcronymUse. Этот Subr проверяет, действительно ли каждый акроним в таблице отображается в документе. Полезно при подгонке документа из существующего шаблона с предварительно заполненной сокращенной таблицей.

Option Explicit 

Sub findAcronyms() 
    Dim findRng As Range, tempRng As Range 
    Dim findStr As String, acroStr As String 
    Dim acroTbl As Table 
    Dim sBool As Boolean 
'################# test code 
Dim testMode As Boolean 
Dim testIdx As Long, testSize As Long, i As Long, j As Long 
testMode = False 
testIdx = 0 
testSize = 100 
Quiet (Not testMode) 
'################# 

'update all field codes and scroll to first occurrence of error 
    i = ThisDocument.Content.Fields.Update 
    If i > 0 Then 
     ThisDocument.ActiveWindow.ScrollIntoView ThisDocument.Range(i) 
     Stop 'and Debug as req'd 
     Exit Sub 
    End If 

    'set acroTbl to ThisDocument's Acronym table 
    Set findRng = ThisDocument.Content 
    findStr = "ACRONYMS" 
    With findRng.Find 
     .ClearFormatting 
     .Style = WdBuiltinStyle.wdStyleHeading1 
     .Text = findStr 
     .MatchWholeWord = False 
     .Forward = False 
     .Wrap = wdFindStop 
     .Format = False 
     .Execute 
     If Not .Found Then 
     MsgBox findStr & ": not found!", vbExclamation 
     Debug.Print "Debug the issue..." 
     Stop 
     Else 
     findRng.MoveStart wdTable 
     findRng.Expand wdTable 
     Set acroTbl = findRng.Tables(1) 
     End If 
    End With 

' Main Loop: find occurrences of "(" and if closing parens ")" is within 7 characters then add to end of Acronym table 
    Set findRng = ThisDocument.Content 
    findStr = "(" 

    With findRng 
     While .MoveStartUntil(findStr) > 0 
     sBool = False 
'################# test code 
If testMode Then 
    .Select 
    Debug.Print .Start 
    testIdx = testIdx + 1 
    If testIdx > testSize Then GoTo Finish 
End If 
'################ 
     Set tempRng = .Duplicate 
     tempRng.End = .Start 
     i = tempRng.MoveEndUntil(")", 7) 'returns # of chars moved plus 1 
     If i > 3 Then 'filter out occurrences of single char parens; (?) 
      acroStr = Mid(tempRng.Text, 2, i) 
      If Right(acroStr, 1) = "s" Then 
       sBool = True 
       acroStr = Left(acroStr, Len(acroStr) - 1) 'exclude redundant plural form of acronym 
      End If 
      If Not acronymExists(acroTbl, acroStr) Then 
       addAcronym acroTbl, findRng.Duplicate, acroStr 
       If sBool Then 'remove plural "s" from acronym definition 
        With acroTbl.Rows.Last.Cells(2).Range 
        j = InStrRev(.Text, "s") 
        If j = Len(.Text) - 2 Then 'all cells contain two hidden characters after the end of text 
         ThisDocument.TrackRevisions = True 
         .Text = Mid(.Text, 1, j - 1) 
         ThisDocument.TrackRevisions = False 
        End If 
        End With 
       End If 
      End If 
      .MoveStart wdCharacter, i 
     Else: .MoveStart wdCharacter, 2 
     End If 
     Wend 
    End With 
Finish: 
    ThisDocument.ActiveWindow.ScrollIntoView acroTbl.Range, False 
    If MsgBox("Accept and Sort Acronym table edits?", 65572, "Accept?") = 6 Then 
     With acroTbl 
     .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, CaseSensitive:=True, LanguageID:=wdEnglishUS 
     .Range.Revisions.AcceptAll 
     End With 
    End If 
    If MsgBox("Verify Acronym table?", 65572, "Verify?") = 6 Then checkAcronymUse 
    Quiet (False) 
End Sub 

Sub checkAcronymUse() 
    Dim Rng As Range, findRng As Range 
    Dim srcDoc As Document 
    Dim myTblStyl As Style 
    Dim srcTbl As Table, tgtTbl As Table 
    Dim myRow As row 
    Dim r As Long 
    Dim findStr As String, srcAddr As String, srcDocName As String 
    Dim findBool As Boolean 
'################# test code 
Dim testMode As Boolean 
Dim testSize As Long 
testMode = False 
testSize = 20 
Quiet (Not testMode) 
'################# 

'set srcTbl to ThisDocument's Acronym table 
    Set Rng = ThisDocument.Content 
    findStr = "ACRONYMS" 
    With Rng.Find 
     .ClearFormatting 
     .Style = WdBuiltinStyle.wdStyleHeading1 
     .Text = findStr 
     .Forward = False 
     .Wrap = wdFindStop 
     .Format = False 
     .Execute 
     If Not .Found Then 
     MsgBox findStr & ": not found!", vbExclamation 
     Debug.Print "Debug the issue..." 
     Stop 
     Else 
     Rng.MoveStart wdTable 
     Rng.Expand wdTable 
     Set tgtTbl = Rng.Tables(1) 
     End If 
    End With 

    ThisDocument.ShowRevisions = True 
    ThisDocument.TrackRevisions = True 

    For Each myRow In tgtTbl.Rows 
     With myRow 
     If Not .HeadingFormat Then 'ignore column headings 
      findStr = Left(.Cells(1).Range.Text, .Cells(1).Range.Characters.Count - 1) 
      If Len(findStr) < 3 Then findStr = Left(.Cells(2).Range.Text, .Cells(2).Range.Characters.Count - 1) 
       Set findRng = ThisDocument.Content 
       findBool = False 'true if Find is outside of tgtTbl 
       With findRng.Find 
        .ClearFormatting 
        .MatchCase = True 
        .MatchWholeWord = False 
        .Text = findStr 
        .Forward = True 
        .Wrap = wdFindStop 
        .Format = False 
        .Execute 
        Do While .Found 'until Find finds other than itself or EOD 
        If findRng.InRange(tgtTbl.Range) Then 
         findRng.Expand wdTable 
        Else 
         findBool = True 
         Exit Do 
        End If 
        findRng.Collapse wdCollapseEnd 
        findRng.End = ThisDocument.Content.End 
        .Execute 
        Loop 
       End With 
'################# test code 
If testMode And .Index > testSize Then Exit For 
'################ 
      If Not findBool Then .Delete 'acronym not used; delete from table 
     End If 
     End With 
    Next myRow 
'################# 
If testMode Then Stop 
'################ 
    tgtTbl.Select 
    ThisDocument.TrackRevisions = False 
    Quiet (False) 
End Sub 

Function acronymExists(acroTbl As Table, str As String) As Boolean 'check for pre-existence of acronym to avoid duplication in acronym table 
    Dim tempRng As Range 

    If str Like Left("#######", Len(str)) Then 'filter out numerical strings 
     acronymExists = True 
    Else 
     Set tempRng = ThisDocument.Range(acroTbl.Columns(1).Cells(2).Range.Start, acroTbl.Columns(1).Cells(acroTbl.Columns(1).Cells.Count).Range.End) 
     tempRng.Find.ClearFormatting 
     With tempRng.Find 
     .Text = str 
     .Forward = True 
     .Wrap = wdFindStop 
     .Format = False 
     .MatchCase = False 
     .MatchWholeWord = True 
     .MatchWildcards = False 
     .MatchSoundsLike = False 
     .MatchAllWordForms = False 
     .Execute 
     acronymExists = .Found 
     End With 
    End If 
End Function 

Sub addAcronym(acroTbl As Table, Rng As Range, str As String) 
    Dim ctr As Integer 

    ctr = Len(str) 
    ThisDocument.ShowRevisions = True 
    ThisDocument.TrackRevisions = True 

    With acroTbl.Rows 
     .Add 
     With .Last 
     .Cells(1).Range.Text = str 
     Rng.Collapse wdCollapseStart 
     'check words at, before, and just after ctr locations for simple correlation match to str 
     If Left(Rng.Previous(wdWord, ctr), 1) = Left(str, 1) Then 
      Rng.MoveStart wdWord, -ctr 
     ElseIf Left(Rng.Previous(wdWord, ctr + 1), 1) = Left(str, 1) Then 
      Rng.MoveStart wdWord, -ctr - 1 
     ElseIf Left(Rng.Previous(wdWord, ctr - 1), 1) = Left(str, 1) Then 
      Rng.MoveStart wdWord, -ctr + 1 
     Else: Rng.MoveStart wdWord, -ctr 'default, grab preceding words matching length of str 
     End If 
     .Cells(2).Range.Text = Trim(Rng.Text) 
     End With 
    End With 
    ThisDocument.TrackRevisions = False 
End Sub 

Sub Quiet(Optional bool As Boolean = True) 
    bool = Not bool 
    With Application 
     .ScreenUpdating = bool 
     .DisplayStatusBar = bool 
    End With 
End Sub