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