Macro not looping through tables
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:
Code:
Sub MacroItalics()
'Helped by Greg Maxey: http://www.vbaexpress.com/forum/show...d=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
