I wrote the below Macro to create circles beneath selected objects in a slide, however as I am very new to VBA, there are some things I would like to ask advice about.

1. The total shapes it can work on is limited to 100 (or whatever number I choose). Although very unlikely the possibility I would need a greater number, how to set it to any value? I tried to enter "n", "x" and others but with no success. Debug would not let it through
2. More importantly, the newly created shapes seem to be aligned, however at a closer look they need some manual intervention to correct the positioning
3. 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 perfect squares or rectangles), on another one they are distorted

Any help is appreciated, thank you

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

CodePudding user response：

Below the working code:

1. I removed any reference to the number of shapes, it was that easy
2. The alignment is fixed by setting the variables center and middle to Single (as per clarification by Steve Rindsberg above)
3. 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