Sub Test() Dim n As Long, i As Long If ActiveShape.Fill.Type <> cdrFountainFill Then MsgBox "The selected shape must have a fountain fill." Exit Sub End If n = ActiveShape.Fill.Fountain.Colors.Count If n > 0 Then For i = 1 To n ActiveShape.Fill.Fountain.Colors(i).Move i * 100 / (n + 1) Next i End IfEnd Sub