Sub Test() Dim ff As FountainFill Dim t As Transparency Dim n As Long, i As Long Set t = ActiveShape.Transparency If t.Type = cdrFountainTransparency Then Set ff = t.Fountain n = 0 For i = 1 To ff.Colors.Count If ff.Colors.GrayLevel(i) < 128 Then n = n + 1 Next i MsgBox "The current shape has " & n & " transparency points with 50% or greater transparency level." Else MsgBox "The shape doesn't have a fountain transparency." End If End Sub