Fragile find & replace

I've tried some of the find & replace macros mentioned at various times in
the discussion groups and they do seem to be rather unreliable with certain
complicated documents.
This one, which I copied from a link, seemed to one of the most
straightforward and runs on most documents but sometimes ends up in an
endless loop in certain cases with text boxes inside what I think is a frame
(hatched box which you can't seem to resize).
Any idea what can be going wrong or how I can diagnosis the problem?

Sub FasterResetSpacing()

Application.ScreenUpdating = False

Dim spacingStoryRange As Range

'First search the main document using the Selection

With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^?"
.Replacement.Text = "^&"
.Forward = True
.Format = True
.Replacement.Font.Spacing = 0
.Replacement.Font.Scaling = 100
.Replacement.Font.Position = 0
.Replacement.Font.Kerning = 0
.Wrap = wdFindContinue
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With

'Now search all other stories using Ranges
For Each spacingStoryRange In ActiveDocument.StoryRanges
If spacingStoryRange.StoryType <> wdMainTextStory Then
With spacingStoryRange.Find
.Text = "^?"
.Replacement.Text = "^&"
.Format = True
.Replacement.Font.Spacing = 0
.Replacement.Font.Scaling = 100
.Replacement.Font.Position = 0
.Replacement.Font.Kerning = 0
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Do While Not (spacingStoryRange.NextStoryRange Is Nothing)
Set spacingStoryRange = spacingStoryRange.NextStoryRange
With spacingStoryRange.Find
.Text = "^?"
.Replacement.Text = "^&"
.Format = True
.Replacement.Font.Spacing = 0
.Replacement.Font.Scaling = 100
.Replacement.Font.Position = 0
.Replacement.Font.Kerning = 0
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Loop
End If
Next spacingStoryRange

End Sub

Any help much appreciated.

David Turner

DavidTurner
Wed Sep 17 14:05:01 PDT 2008

After consulting the archives, it sounds like I have a similar problem to the
Find/Replace bug reported by Jean-Guy-Marcil in July. When I isolate one of
the offending frame shapes containing text boxes and run the macro on it, it
goes into an infinite loop searching from one text box to another.
Did anyone come up with a solution?

David Turner

"I have a document that has Figures made up of many textboxes connected by
lines. They were created by converting embeded Visio drawings into enhanced
meta files, and then edited by right clicking on them. The Figures were
cleaned up so that they consit only of lines and textboxes containing
textframes. All useless shapes that the Edit command created have been
removed. (This complicated process was used because it would have been too
long to recreate the complex Figures from scratch within Word. It was overall
faster to convert these complex English Figures into editable ones so that
people who do not have Visio installed can easily translate them.) Those
figures are held within a 1x1 table.

Here is the bug:
All highlighted text in the main story is picked up.
Many of the shapes within the figures have highlighted text in them. Only
about 5% of the highlighted text is being picked up by the function. I
debugged the code and I know that the second ""With rgeFind.Find" above is
being executed, but the corresponding "Do While .Execute" fails, as if the
range from the textframes did not contained highlighted text when in fact it
does..."

DavidTurner
Thu Sep 18 00:18:00 PDT 2008

As Tony Jollans pointed out, collapsing the range just before starting the
find seems to do the trick. Maybe the various find and replace anywhere
macros need to include this to allow them to correctly search in textframes
of this type?

Do While Not (spacingStoryRange.NextStoryRange Is Nothing)
Set spacingStoryRange = spacingStoryRange.NextStoryRange
spacingStoryRange.Collapse wdCollapseEnd
With spacingStoryRange.Find
.Text = "^?"
.Replacement.Text = "^&"
.Format = True
.Replacement.Font.Spacing = 0
.Replacement.Font.Scaling = 100
.Replacement.Font.Position = 0
.Replacement.Font.Kerning = 0
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
Loop


David Turner