As a lawyer with a computer science degree, I like to write the occasional bit of software, often in Microsoft WordBasic.
We recently changed the fonts in our documents – Palatino Linotype for our letters and Gill Sans Nova Medium for our documents and e-mails.
A macro to change the fonts in our precedents was called for and you would think that a Macro to change the fonts would be very simple. “Surely you could just record a Replace All operation?”, you might say, but unfortunately, the answer is “No” because Microsoft Word does not make it that simple.
There is a very good code here. However, it does not seem to work properly if the document has multiple sections. Nor does it change the fonts of all of the numbered and lettered lists.
Through a lot of trial an error, I found that the code below does the trick.
It does not change the font of watermarks. There might be other parts of the document that it does not covert. Please let me know if you find any more. Better still, please send me the code that remedies the problem. 🙂
Regards, Michael Paterson
Sub ChangeAllFontsThroughout()
‘
‘ ChangeFont Macro
‘
‘
Dim oSection As Section
Dim rngStory As Word.Range
Dim lngValidate As Long
Dim oShp As Shape
‘Fix the skipped blank Header/Footer problem as provided by Peter Hewett.
lngValidate = ActiveDocument.Sections(1).Headers(1).Range.StoryType
‘Iterate through all story types in the current document.
Set rngStory = ActiveDocument.StoryRanges(wdMainTextStory)
Call ChangeFont(rngStory)
For Each oSection In ActiveDocument.Sections ‘ oSection.Range.Select
For Each rngStory In ActiveDocument.StoryRanges
‘Iterate through all linked stories.
Do
If rngStory.StoryType <> wdMainTextStory Then
Call ChangeFont(rngStory)
End If
Set rngStory = rngStory.NextStoryRange
Loop Until rngStory Is Nothing
Next
Next
Selection.HomeKey Unit:=wdStory
End Sub
Sub ChangeFont(rngStory)
Dim currentList As Range
Dim i, numLists As Integer
numLists = rngStory.ListParagraphs.Count
For i = 1 To numLists
‘rngStory.Select
With rngStory.ListParagraphs(i)
.SelectNumber
‘ put your old and new fonts here
If Selection.Font.Name = “Calibri” Then
Selection.Font.Name = “Gill Sans Nova Medium”
End If
If Selection.Font.Name = “Gill Sans MT” Then
Selection.Font.Name = “Gill Sans Nova Medium”
End If
If Selection.Font.Name = “Arial” Then
Selection.Font.Name = “Gill Sans Nova Medium”
End If
If Selection.Font.Name = “Arial Narrow” Then
Selection.Font.Name = “Gill Sans Nova Medium”
End If
If Selection.Font.Name = “Times New Roman” Then
Selection.Font.Name = “Palatino Linotype”
End If
End With
Next
‘ and here …
Call SwapFonts(rngStory, “Calibri”, “Gill Sans Nova Medium”)
Call SwapFonts(rngStory, “Gill Sans MT”, “Gill Sans Nova Medium”)
Call SwapFonts(rngStory, “Arial”, “Gill Sans Nova Medium”)
Call SwapFonts(rngStory, “Arial Narrow”, “Gill Sans Nova Medium”)
Call SwapFonts(rngStory, “Times New Roman”, “Palatino Linotype”)
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
‘ and here …
Call SwapFonts(oShp.TextFrame, “Calibri”, “Gill Sans Nova Medium”)
Call SwapFonts(oShp.TextFrame, “Gill Sans MT”, “Gill Sans Nova Medium”)
Call SwapFonts(oShp.TextFrame, “Arial”, “Gill Sans Nova Medium”)
Call SwapFonts(oShp.TextFrame, “Arial Narrow”, “Gill Sans Nova Medium”)
Call SwapFonts(oShp.TextFrame, “Times New Roman”, “Palatino Linotype”)
End If
Next
End If
Case Else
‘Do Nothing
End Select
On Error GoTo 0
End Sub
Sub SwapFonts(rngStory, OldFont, Newfont)
With rngStory.Find
.ClearFormatting
.Font.Name = OldFont
.Text = “”
.Replacement.Text = “”
.Forward = True
.Wrap = wdFindStop
.format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
With .Replacement
.ClearFormatting
.Font.Name = Newfont
End With
End With
rngStory.Find.Execute Replace:=wdReplaceAll
End Sub