Change font programmatically

I need to modify text and change font programmatically.

In the following code,  I know ActiveShape doesn't work, but what will?

Sub TR1()
Dim sh As Shape
Dim sr As ShapeRange
Dim i As Integer
Dim p As Page

For Each p In ActiveDocument.Pages
p.Activate
   Set sr = p.Shapes.FindShapes(Type:=cdrTextShape)
     For Each sh In sr
         ActiveShape.Text.Story.Text = Chr(CDec(&H5F)) + ActiveShape.Text.Story.Text + Chr(CDec(&H5F))
         ActiveShape.Text.Story.Font = "Charlotte font"
    Next sh
Next p
End Sub