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