Create Centered Shapes beneath selected ones - vba

Question

I wrote code to create circles beneath selected objects in a slide.
The total shapes it can work on is limited to 100 (or whatever number I
choose).
How to set it to any value?
I tried to enter "n", "x" and others. Debug would not let it through.
More importantly, the newly created shapes seem to be aligned,
however at a closer look they need manual intervention to
correct the positioning.
The behavior does not seem consistent across files: on the .pptm
where the macro is stored the shapes are perfect circles (no matter
if the selection is made of squares or rectangles), on
another one they are distorted.
Sub CreateNewShapeAndAlign()
Dim Shp(1 To 100) As Shape
Dim Shp_Cntr As Long
Dim Shp_Mid As Long
Dim New_Shapes As Shape
Dim Ratio As Double
Dim x, y As Integer
Ratio = 1.4
Set myDocument = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber)
For Each Shp(1) In ActiveWindow.Selection.ShapeRange
Shp_Cntr = Shp(1).Left + Shp(1).Width / 2
Shp_Mid = Shp(1).Top + Shp(1).Height / 2
x = ActiveWindow.Selection.ShapeRange.Count
For y = 1 To x
If Shp(1) Is Nothing Then
Set Shp(1) = ActivePresentation.Slides.Range.Shapes(y)
Else
Set Shp(y) = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber).Shapes(y)
End If
Next y
Set New_Shape = myDocument.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - ((Shp(1).Width * Ratio) / 2), Top:=Shp_Mid - ((Shp(1).Height * Ratio) / 2), Width:=Shp(1).Width * Ratio, Height:=Shp(1).Height * Ratio)
New_Shape.Fill.ForeColor.RGB = RGB(100, 100, 100)
New_Shape.Line.Visible = msoFalse
Next
ActiveWindow.Selection.ShapeRange.ZOrder msoBringToFront
End Sub

Answer 1

Below the working code:
I removed any reference to the number of shapes, it was that easy
The alignment is fixed by setting the variables center and middle to
Single (as per clarification by Steve Rindsberg above)
I forced the shapes to be circles by passing the width value to the height
I further cleaned up and removed unnecessary loops I had left from previous attempts at aligning the shapes. I guess variable Ratio should be Single as well, however I don't think it matters so much as it has only two digits after the comma so there is nothing to round.
Sub CreateUnderneath()
Dim Shp As Shape
Dim Shp_Cntr As Single 'Center of Selected Shapes
Dim Shp_Mid As Single 'Middle of Selected Shapes
Dim New_Shape As Shape
Dim Ratio As Double 'Size of new shape relative to selected one underneath
Ratio = 1.45
Set myDocument = ActivePresentation.Slides(ActiveWindow.View.Slide.SlideNumber)
If ActiveWindow.Selection.Type = 0 Then
MsgBox "Nothing has been selected"
Else
For Each Shp In ActiveWindow.Selection.ShapeRange'.GroupItems 'to have it work inside groups
Shp_Cntr = Shp.Left + Shp.Width / 2
Shp_Mid = Shp.Top + Shp.Height / 2
' Circle
Set New_Shape = myDocument.Shapes.AddShape(Type:=msoShapeOval, Left:=Shp_Cntr - ((Shp.Width * Ratio) / 2), Top:=Shp_Mid - ((Shp.Width * Ratio) / 2), Width:=Shp.Width * Ratio, Height:=Shp.Width * Ratio)
New_Shape.Fill.ForeColor.RGB = RGB(0, 0, 0)
New_Shape.Line.Weight = 0.75
New_Shape.Line.Visible = msoFalse
New_Shape.LockAspectRatio = msoTrue
New_Shape.Name = "ShepeBelow"
Next
ActiveWindow.Selection.ShapeRange.ZOrder msoBringToFront
End If
End Sub