Sub Test() Dim srOld As ShapeRange, srNew As ShapeRange Set srOld = ActiveSelectionRange If srOld.Count <> 0 Then Set srNew = srOld.Duplicate(0.05, -0.05) srNew.ApplyUniformFill CreateRGBColor(50, 50, 50) srNew.OrderBackOne End IfEnd Sub