Changing fonts throughout document including headers footers and footnotes

[Kim]

I need to create a macro to change all fonts of "Times" to "Times New
Roman" in a document. I have that code below. However, my code does not
change the font in some places, for example, in some parts of tables,
headers/footers and in footnotes. How do I add to this code to cover
those areas too?

Sub Times_to_TNR()
'
' Times_to_TNR Macro
' Macro created 1/13/2007 by
'


' Turn screen updating off
Application.ScreenUpdating = False

Selection.HomeKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
'**********************
.Text = ""
.Font.Name = "Times"

.Replacement.Text = ""
.Replacement.Font.Name = "Times New Roman"
'**********************
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
MsgBox "Done converting font style Times to Times New Roman",
vbOKOnly

End Sub

 

[Greg Maxey]

Kim,

You have to process each storyrange in the document.

See: http://word.mvps.org/faqs/customization/ReplaceAnywhere.htm

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
Dim pFindTxt As String
Dim pReplaceTxt As String
'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
ResetFRParameters
pFindTxt = ""
pReplaceTxt = ""
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SrcAndRplInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SrcAndRplInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
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
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Name = "Tahoma"
.Replacement.Font.Name = "Times New Roman"
.Execute Replace:=wdReplaceAll
End With
End Sub
Sub ResetFRParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub

 

[Kim]

Greg,

Thanks for your help.

This code did not replace in my Header and Footer. How can I add this
to the code below so that story is covered?

Thanks, Kim

 

[Greg Maxey]

Kim,

Sorry.

Replace the SrchAndRplInStory routine with this:

Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Name = "Times New Roman"
.Replacement.Font.Name = "Tahoma"
.Format = True "Added this line
.Execute Replace:=wdReplaceAll
End With
End Sub

 

[Kim]

Greg,

Forgive me, I am really NEW at this! But here is my code now. It still
is not changing in my headers and footers. What I am doing
wrong/missing? Thanks, Kim

Public Sub FindReplaceAnywhere()
Dim rngStory As Word.Range
Dim lngJunk As Long
Dim oShp As Shape
Dim pFindTxt As String
Dim pReplaceTxt As String
'Fix the skipped blank Header/Footer problem
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
ResetFRParameters
pFindTxt = ""
pReplaceTxt = ""
'Iterate through all story types in the current document
For Each rngStory In ActiveDocument.StoryRanges
'Iterate through all linked stories
Do
SrcAndRplInStory rngStory, pFindTxt, pReplaceTxt
On Error Resume Next
Select Case rngStory.StoryType
Case 6, 7, 8, 9, 10, 11
If rngStory.ShapeRange.Count > 0 Then
For Each oShp In rngStory.ShapeRange
If oShp.TextFrame.HasText Then
SrcAndRplInStory oShp.TextFrame.TextRange, _
pFindTxt, pReplaceTxt
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
End Sub
Public Sub SrcAndRplInStory(ByVal rngStory As Word.Range, _
ByVal strSearch As String, _
ByVal strReplace As String)
With rngStory.Find
.ClearFormatting
.Replacement.ClearFormatting
.Font.Name = "Times"
.Replacement.Font.Name = "Times New Roman"
.Format = True
.Execute Replace:=wdReplaceAll
End With
End Sub

Sub ResetFRParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
End Sub

 

[Greg Maxey]

Kim,

I don't see anything wrong. I can't test your code because I don't have a
font named "Times."

I did create new document and put text in several storyranges (including
headers and footers) and formatted it as "Tahoma" font. All instances where
changed to "Times New Roman"

I used.

..Font.Name = "Tahoma"
Replacement.Font.Name = "Times New Roman"

Are you sure the Header and Footer text is formatted with a font named
"Times"

E-mail the document to me and if I get a chance I will try to figure it out.

 

[Kim]

Greg, what is your correct e-mail address?

Thanks,
Kim