Sub Test() Dim d As Document Dim sel As Shape, s As Shape Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double, Shift As Long Dim c As New Color Set d = ActiveDocument c.UserAssign While d.GetUserArea(x1, y1, x2, y2, Shift, 100, False, cdrCursorWinCross) = 0 Set sel = d.ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, False) For Each s In sel.Shapes s.Fill.ApplyUniformFill c Next s WendEnd Sub