Range.Find - 在wdInFieldResult用;实测值麻烦

Question

缩写搜索

当findRng.Find成功地发现了一个域结果中搜索文本（如目录）下一个.Execute开始在TOC的开始而不是在之前的findRng.Find文档的开始位置。这可以通过选择findRng.select来直观地显示。每findRng的开始和结束的属性，选择不应该包括TOC的开始，但它确实，这似乎是什么.Find方法也使用，因为它成为苹果公司总部地址;即一个无限循环。 ;）

，你可以看它是否符合预期，直到附近的子程序底部的.Execute声明findRng.Start和.END的值。

除非有人能解决的范围内复位的问题，我很乐意只是寻找一种方法来快速确定触发wdInFieldResult产生真正与生活运动场上的.END位置。

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

避免了Field.Result的破坏行为，实际上简化了例程。相反，使用Range.MoveStartUntil产生更直接的处理。

findAcronyms例程通过ThisDocument.Content查找每个连续出现的开放parens“（”，直到文档结束。找到一个开放的parens，运行几个过滤测试以消除不希望的结果，例如数字字符串和过度缩写长度（限于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