Private Sub FindTextOnPage(sFont$)
    '##查找字体
    Dim sr As ShapeRange, s As Shape, sRect As Shape
    Dim x#, y#, w#, h#, cc&
    Set sr = ActivePage.Shapes.FindShapes(Query:="!@com.layer.name = 'Desktop'")
    If sr.Count = 0 Then MsgBox "No shapes found!": Exit Sub
    cc = 0
    Set sRect = ActiveLayer.CreateRectangle(1, 1, 5, 5)
    sRect.Fill.ApplyUniformFill CreateCMYKColor(0, 100, 100, 0)
    sRect.Outline.SetNoOutline
    sRect.Name = "Highlighted Font Box"
    For Each s In sr
        If s.Type = cdrTextShape Then
            If s.Text.Story.Font = sFont Then
                cc = cc + 1
                s.GetBoundingBox x, y, w, h
                sRect.SetBoundingBox x, y, w, h
                sRect.OrderBackOf s
                ActiveDocument.ClearSelection
                s.AddToSelection
                MsgBox cc
            End If
        End If
    Next
    sRect.Delete
End Sub