Sub Test() Dim s As Shape, r As Shape Dim x As Double, y As Double, sx As Double, sy As Double If ActiveSelection.Shapes.Count = 1 Then Set s = ActiveShape s.GetBoundingBox x, y, sx, sy Set r = ActiveLayer.CreateRectangle2(x, y, sx, sy) r.Fill.UniformColor.RGBAssign 225, 225, 225 r.OrderBackOf s End IfEnd Sub