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

Tags: , , , , ,