Replace a font in a text through all pages with a macro

yep, already know about that.  I just want to be able to hit one button one time and have the command automatically go through all pages.

Hi.

Try this:

Sub textFont1()
    Dim p As Page, s As Shape, sr As ShapeRange
    Dim i&, f$, fNew$
   
    f = "Arial" 'your font to find
    fNew = "Arial Black" 'new font
  
    i = ActivePage.Index
    For Each p In ActiveDocument.Pages
        p.Activate
        Set sr = ActivePage.Shapes.FindShapes(Query:="@type = 'text:artistic' and @com.text.story.font = '" & f & "'")
        For Each s In sr
            s.text.Story.Font = fNew
        Next s
    Next p
    ActiveDocument.Pages(i).Activate
End Sub

~John

Hi John,

just one question, how can I adapt this macro to change any type of font to a new one. Because I have documents with 3 or 4 different fonts, and I want to convert all of them to the same (and the fonts could change from one document to others).

Is there any wayto make this?

Thank you and best regards,

Hi.

Change this line:

Set sr = ActivePage.Shapes.FindShapes(Query:="@type = 'text:artistic' and @com.text.story.font = '" & f & "'")

to

Set sr = ActivePage.Shapes.FindShapes(Query:="@type = 'text:artistic' or @type = 'text:paragraph'")

Let me know if it works because I didn't test.

~John

Hi John,

it works PERFECT!!!!

Thank you very much for your help!