Sub Test() Dim s As Shape Dim x As Double, y As Double, w As Double, h As Double ActiveDocument.ReferencePoint = cdrBottomLeft For Each s In ActivePage.Shapes s.GetBoundingBox x, y, w, h ActiveLayer.CreateRectangle2 x, y, s.SizeWidth, s.SizeHeight Next sEnd Sub