Macro not looping through tables

[rook]

Hello,

i have this great code thanks to the help of Greg Maxey. Idea is simple - loop through whole document, including headers, and highlight text that is bold or italics. Unfortunately it's not looping through tables and frames - it stucks in first "DoEvents". I have experimented with everything I could find online, but no luck. I was thinking about adding extra part dedicated to looping through tables, but I couldn't adapt anything. So any advise, suggestion will be greatly appreciated :)

Here's the code:



Sub MacroItalics()
'Helped by Greg Maxey: http://www.vbaexpress.com/forum/show...d=1#post403227 (http://www.vbaexpress.com/forum/showthread.php?67557-Find-and-highlight-formatting-issue-with-big-documents&p=403227&posted=1#post403227)


Dim rngstory As Word.Range
Set rngstory = ActiveDocument.StoryRanges(wdMainTextStory)
Dim lngJunk As Long
Dim oShp As Shape
Dim i As Long
Application.ScreenUpdating = False
'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
For lngJunk = 1 To 3
oResetFRParams2 Selection.Range

'Iterate through all story types in the current document
For Each rngstory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
oItalicBold rngstory, lngJunk
On Error Resume Next
rngstory.Fields.Update
Select Case rngstory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngstory.ShapeRange.Count > 0 Then
For Each oShp In rngstory.ShapeRange
If Not oShp.TextFrame.TextRange Is Nothing Then
oItalicBold oShp.TextFrame.TextRange, lngJunk
End If
Next
End If
Case Else
'Do Nothing
End Select
On Error GoTo 0
'Get next linked story (if any)
Set rngstory = rngstory.NextStoryRange
Loop Until rngstory Is Nothing

Next
Next lngJunk
Application.ScreenUpdating = True

End Sub


Private Sub oItalicBold(ByVal rngstory As Word.Range, lngRouter As Long)
Application.ScreenUpdating = False
With rngstory.Find
On Error Resume Next

Select Case lngRouter

Case 1
.Font.Italic = True
While .Execute
rngstory.HighlightColorIndex = wdPink
rngstory.Collapse wdCollapseEnd
DoEvents
Wend

Case 2
.Font.Bold = True
While .Execute
rngstory.HighlightColorIndex = wdPink
rngstory.Collapse wdCollapseEnd
DoEvents
Wend
End Select

On Error GoTo 0
End With

' Application.ScreenUpdating = True
End Sub

Sub oResetFRParams2(oRng As Range)

With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With

End Sub

[macropod]

When performing Find/Replace operations based on attributes other that text (e.g. bold, Styles, highlights, shading, etc.) and the content can occur in a table or at the end of the document, additional measures are need. See, for example: https://www.msofficeforums.com/135733-post2.html