Sub Test() Dim s1 As Shape, s2 As Shape, sr As ShapeRange Set s1 = ActiveLayer.CreateRectangle(0, 0, 5, 5) s1.Fill.ApplyFountainFill Set s2 = ActiveLayer.CreateEllipse(1, 1, 6, 6) With s2.CreateLens(cdrLensFishEye, 100).Lens .Freeze Set sr = .Ungroup End With sr.Move 4, 0End Sub