Folks;
After some help from Jezebel and Peter Jamison I have the code below
working. YEAH!
BUT (you knew that was coming right!)
It is dog slow. It takes several minutes to process a one page
document.
I'm looking for ANY angles to improve the code! So let 'er rip!!!
One thought I have is that Sub ReplaceRoster just blindly keeps
hammering away with 'replace' when the tags have been exhausted. So
I'd like to tweak it so it stops when there are no more '<' in the
text...
But I'm a little puzzled how best to structure that change.
Thanks Again Jezebel and Peter!!
Steve
_____________________
Dim storyRange As Word.Range
Dim tRange as Word.Range
Dim junk As Long
Dim shape As Shape
junk = ActiveDocument.Sections( 1 ).Headers( 1 ).Range.StoryType
For Each storyRange In ActiveDocument.StoryRanges
Do
Select Case storyRange.StoryType
Case wdPrimaryHeaderStory
ReplaceRoster storyRange
On Error Resume Next
If storyRange.ShapeRange.Count > 0 Then
For Each shape In storyRange.ShapeRange
Select Case shape.Type
Case msoTextBox
If shape.TextFrame.HasText Then
Set tRange = shape.TextFrame.TextRange
tRange.Find.Execute FindText:=\"<\", Forward:=True
If tRange.Find.Found = True Then ReplaceRoster
shape.TextFrame.TextRange
End If
Case Else
End Select
Next
End If
Case Else
End Select
On Error GoTo 0
Set storyRange = storyRange.NextStoryRange
Loop Until storyRange Is Nothing
Next
Public Sub ReplaceRoster(ByVal myRange As Word.Range)
ReplaceInRange myRange, \"<SOrg>\", \"Q$SOrg\"
ReplaceInRange myRange, \"<SFullName>\", \"Q$SFullName\"
[ ...45 more such lines...]
End Sub
Public Sub ReplaceInRange(ByVal myRange As Word.Range, ByVal strSearch
As String , ByVal strReplace As String )
With myRange.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = strSearch
.Replacement.Text = strReplace
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End Sub