Vba Range.Find-在wdInFieldResult中发现

首字母缩略词搜索

当findRng.Find成功发现字段结果（如目录）中的搜索文本时，下一个.Execute开始于TOC的开始位置，而不是从上一个findRng.Find在文档后面设置的开始位置。通过选择findRng.select可以直观地显示这一点。根据findRng的开始和结束属性，选择不应包括TOC的开始，但它确实包含TOC的开始，这似乎是.Find方法所使用的，因为它成为了苹果公司总部地址；i、 例如，一个无限循环

您可以观察findRng.Start和.End的值，直到子例程底部附近的.Execute语句出现之前，它们都是预期的值

除非有人能解决范围重置问题，否则我很高兴能找到一种方法来快速确定触发WDI的字段的.End位置，从而产生真实的结果并继续生活

Sub findAcronyms（）
调光范围，温度范围
模糊oFld As场
Dim findStr作为字符串，acroStr作为字符串
如表所示，将其变暗
“测试代码”
Dim testMode作为布尔值
Dim testIdx长，testSize长，i长
testMode=True
testIdx=0
testSize=25
如果是testMode，那么
ThisDocument.ShowRevisions=True
ThisDocument.TrackRevisions=True
如果结束
安静（非测试模式）
'#################
'将Acrontbl设置为此文档的首字母缩略词表
Set findRng=ThisDocument.Content
findStr=“首字母缩写”
用findRng，找到
.ClearFormatting
.Style=WdBuiltinStyle.wdStyleHeading1
.Text=findStr
.Forward=False
.Wrap=wdFindStop
.Format=False
.执行
如果没有，那么找到了
MsgBox findStr&“：未找到！”，vb感叹号
停止
调试。打印“调试问题…”
其他的
findRng.MoveStart wdTable
展开wdTable
Set acroTbl=findRng.Tables（1）
如果结束
以
“查找出现的”（“如果结束参数”（）在7个字符以内，则添加到首字母缩略词表的末尾
Set findRng=ThisDocument.Content
findStr=“（”
用findRng，找到
.ClearFormatting
.Text=findStr
.Forward=True
.Wrap=wdFindStop
.Format=False
.执行
执行While.Found'直到Find找到除自身或EOD之外的其他对象
“测试代码”
如果是testMode，那么
查找。选择
Debug.Print findRng.Start
testIdx=testIdx+1
如果testIdx>testSize，则
如有必要，停止并调试
出口接头
如果结束
如果结束
'################
i=findRng.MoveEndUntil（“）”，7）
如果i>2，而不是像Left（findStr&“findStr”）这样的findRng.Text_
Len（findRng.Text））然后
'在添加到表中之前，请检查首字母缩略词是否存在
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
用tempRng.Find
.Text=Mid（findRng.Text，2，i）
.Forward=True
.Wrap=wdFindStop
.Format=False
.MatchCase=False
.MatchWholeWord=True
.MatchWildcards=False
.MatchSoundsLike=False
.MatchAllWordForms=False
.执行
如果未找到，则“继续向表中添加新的首字母缩略词”
用横排
添加
最后一次
.Cells（1）.Range.Text=Mid（findRng.Text，2，i）
i=findRng.Start
findRng.折叠wdCollapseStart
findRng.MoveStart wdCharacter，-1
findRng.MoveStart wdWord_
-.单元格（1）.范围.Characters.Count
.Cells（2）.Range.Text=Trim（findRng.Text）
findRng.Start=i+1
Debug.Print.Cells（1）.Range.Text、.Cells（2）.Range.Text
以
以
如果结束
以
其他：findRng.MoveStart wdWord“跳过两个字母的首字母缩写
如果结束
如果查找信息（wdInFieldResult），则
findRng.MoveStart wdparagration’我需要确定如何从字段结果中获取结果，而不是更好的解决方案
如果找到其他信息（wdWithInTable），则
如果findRng.InRange（findRng.Tables（1）.Range.Cells（findRng.Tables（1）.Range.Cells.Count）.Range），则“测试最后一个单元格中是否存在”
展开wdTable
找到了，塌陷了，塌陷了
其他的
findRng.MoveStart wdCell
如果结束
其他的
findRng.MoveStart wdWord
如果结束
“测试代码”
如果选择testMode，则选择findRng
'################
找到了，塌陷了，塌陷了
findRng.End=ThisDocument.Content.End
.执行
环
以
停止
端接头

避免了字段的中断行为。结果实际上简化了例程。相反，使用R

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