Sub Test() Dim sr As New ShapeRange Dim s As Shape For Each s In ActivePage.Shapes If s.Fill.Type = cdrFountainFill Then sr.Add s Next s sr.ApplyNoFill End Sub