在所选形状下方创建居中形状

Question

我编写代码在幻灯片中选定的对象下方创建圆圈。

它可以处理的总形状限制为 100 个（或我认为的任何数量选择）。
如何设置为任意值？
我试着输入“n”、“x”等。调试不会让它通过。
更重要的是，新创建的形状似乎对齐了，然而仔细观察，他们需要人工干预更正定位。
文件之间的行为似乎不一致：在 .pptm 上存储宏的地方形状是完美的圆形（无论如果选择由正方形或矩形组成），则另一个他们被扭曲了。

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

下面的工作代码：

我删除了对形状数量的任何引用，就这么简单
通过将变量 center 和 middle 设置为来固定对齐方式单身（根据上面 Steve Rindsberg 的澄清）
我通过将宽度值传递给高度来强制形状为圆形

我进一步清理并删除了之前尝试对齐形状时留下的不必要的循环。我想变量 Ratio 也应该是 Single，但是我认为它并不重要，因为它在逗号后只有两位数，所以没有什么可以四舍五入的。

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

在所选形状下方创建居中形状

Create Centered Shapes beneath selected ones

vba

powerpoint