Looking for a better way

[Greg]

Earlier I was helping a user that wanted a VBA find routine that would
start at the IP and go to the end of the document. On reaching the
end, the user wanted a pop-up to querry if the routine should loop to
the begining of the document. I got that far without any trouble.
However, I got tripped up trying to stop the routine at the IP after it
began searching from the document start. I scrapped together something
that appears workable, but it seems I am missing something simple.
Review and comments welcomed.

Sub ScratchMacro()
Dim oRng As Range
Dim oRng1 As Range
Dim oRng2 As Range
Dim i As Long
Dim bLooped As Boolean
Set oRng1 = ActiveDocument.Content
Set oRng2 = ActiveDocument.Content
i = Selection.Start
oRng1.Start = i
oRng2.End = i
Set oRng = oRng1
bLooped = False
LoopTwo:
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop
Do While .Execute
If bLooped = True And oRng.Start > i Then
MsgBox "Finished."
Exit Sub
End If
oRng.HighlightColorIndex = wdYellow
Select Case MsgBox("Do you want to remove italics from: " _
& oRng.Text, vbYesNoCancel, "Action")
Case Is = vbYes
oRng.Font.Italic = False
oRng.HighlightColorIndex = wdNoHighlight
oRng.Collapse wdCollapseEnd
Case Is = vbNo
oRng.HighlightColorIndex = wdNoHighlight
oRng.Collapse wdCollapseEnd
Case Is = vbCancel
oRng.HighlightColorIndex = wdNoHighlight
Exit Do
End Select
Loop
End With
If bLooped = False Then
If MsgBox("Do you want to loop to start?", _
vbYesNo, "Loop to Start") = vbYes Then
bLooped = True
Set oRng = oRng2
GoTo LoopTwo
End If
End If
End Sub

 

[Tony Jollans]

I could pick a few holes in your code (like Cancel doesn't work before you
have looped - also it doesn't highlight for me unless I add a screen refresh
to force it) - but I don't think you're missing anything simple!

I have tried both with the Find object and the Find Dialog object and I
cannot get anything in code to fire the F&R ending and message when it's
looped back to where it started from. You can get the builtin "do you want
to continue from the beginning" message but there doesn't appear to be any
way to tell that's it's been issued or to stop it being issued again when
the Find gets to the end again, without remembering and checking for
yourself.

FWIW, here's my best effort to date - and neither yours nor mine copes quite
properly when the initial IP is within an italicised string, but I got bored
......

Sub FindAndReplace()

Dim StartPoint As Range
Dim PrevFound As Range
Dim Looped As Boolean

Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = ""
.Replacement.Text = "^&"
.Forward = True
.Wrap = wdFindAsk
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchKashida = False
.MatchDiacritics = False
.MatchAlefHamza = False
.MatchControl = False
.MatchByte = False
.CorrectHangulEndings = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With

Selection.Find.Font.Italic = True
Selection.Find.Replacement.Font.Italic = False

Set StartPoint = Selection.Range.Duplicate

Do While Selection.Find.Execute

If Not Looped Then
If PrevFound Is Nothing Then
Looped = (Selection.Start < StartPoint.Start)
Else
Looped = (Selection.Start <= PrevFound.Start)
End If
End If

If Looped Then
If Selection.Start >= StartPoint.Start Then Exit Do
End If

Set PrevFound = Selection.Range.Duplicate

Select Case MsgBox("Change?", vbYesNoCancel)

Case vbYes
With Selection
.Collapse Direction:=wdCollapseStart
.Find.Execute Replace:=wdReplaceOne
.Collapse Direction:=wdCollapseEnd
End With

Case vbCancel
Exit Do

End Select

Loop

StartPoint.Select

Set StartPoint = Nothing
Set PrevFound = Nothing

MsgBox "All requested changes have been made"

End Sub

 

[Greg Maxey]

Tony,

To fix "Cancel" I just changed Exit Do to Exit Sub. I don't know why you
don't get the highlight. It works for me in any view.

Your right about the starting in a string of italic text. Using my code the
first found range is from the IP to the end of the string. If I loop bac to
the start then the last found range includes the entire string (the part
before and the part after the IP). I don't really understand why text is
found outside the initially defined range, but don't see any way around it.

 

[Greg Maxey]

Tony,

Actually I did find a way to handle the split string of italics. The code
is getting longer and longer but seems to work. Always feel free to pick
holes. I freely admit that I have lots to learn and it is struggling and
taking pointers from you and others that improves my budding skills.

Sub ScratchMacro()
Dim oRng As Range
Dim oRng1 As Range
Dim oRng2 As Range
Dim i As Long
Dim bLooped As Boolean
Dim bFinished As Boolean
Set oRng1 = ActiveDocument.Content
Set oRng2 = ActiveDocument.Content
i = Selection.Start
oRng1.Start = i
oRng2.End = i
Set oRng = oRng1
bLooped = False
bFinished = False
LoopTwo:
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Font.Italic = True
.Wrap = wdFindStop
Do While .Execute
If bLooped = True And oRng.Start > i Then
MsgBox "Finished."
Exit Sub
ElseIf bLooped = True And oRng.End > i Then
oRng.End = i
bFinished = True
End If
oRng.HighlightColorIndex = wdYellow
Select Case MsgBox("Do you want to remove italics from: " _
& oRng.Text, vbYesNoCancel, "Action")
Case Is = vbYes
oRng.Font.Italic = False
oRng.HighlightColorIndex = wdNoHighlight
oRng.Collapse wdCollapseEnd
If bFinished Then
MsgBox "Finished"
Exit Sub
End If
Case Is = vbNo
oRng.HighlightColorIndex = wdNoHighlight
oRng.Collapse wdCollapseEnd
If bFinished Then
MsgBox "Finished"
Exit Sub
End If
Case Is = vbCancel
oRng.HighlightColorIndex = wdNoHighlight
Exit Sub
End Select
Loop
End With
If bLooped = False Then
If MsgBox("Do you want to loop to start?", _
vbYesNo, "Loop to Start") = vbYes Then
bLooped = True
Set oRng = oRng2
GoTo LoopTwo
Else
MsgBox "Finished"
End If
End If
End Sub