Sub Test() Dim s As Shape Dim x As Double, y As Double ActiveDocument.ReferencePoint = cdrBottomLeft For Each s In ActivePage.Shapes s.GetSize x, y ActiveLayer.CreateRectangle2 0, 0, x, y Next sEnd Sub