Vertical distibution of slected shapes by shapes centres in PowerPoint

Question

I try to write a VBA code that will distirbute verticaly selected shapes but based on shapes centres, not spaces between shapes (as default in powerpoint distribute vertaly function). I have started to writing a code but it does not work well from logical perspective in all usecases

I would be glad to help me find error and how to fix that

Sub DistributeShapesVerticallyv2()


    Dim oShp As Shape
    Dim oSld As Slide
    Dim oSel As Selection
    Dim i As Integer
    Dim shapeCount As Integer
    Dim minY As Single
    Dim maxY As Single
    Dim spaceBetween As Single

    ' Get the current slide and selection
    Set oSld = ActiveWindow.View.Slide
    Set oSel = ActiveWindow.Selection

    ' Check if there are at least two shapes selected
    If oSel.Type <> ppSelectionShapes Or oSel.ShapeRange.Count < 2 Then
        MsgBox "Please select at least two shapes to distribute vertically."
        Exit Sub
    End If

    ' Sort the shapes by their Y values
    
        For i = 1 To oSel.ShapeRange.Count - 1
            For j = i + 1 To oSel.ShapeRange.Count
                If oSel.ShapeRange(i).Top + oSel.ShapeRange(i).Height / 2 > oSel.ShapeRange(j).Top + oSel.ShapeRange(j).Height / 2 Then
                    oSel.ShapeRange(i).ZOrder msoSendBack
                End If
            Next j
        Next i

    ' Initialize variables
    minY = oSel.ShapeRange(1).Top + oSel.ShapeRange(1).Height / 2
    shapeCount = oSel.ShapeRange.Count
    maxY = oSel.ShapeRange(shapeCount).Top + oSel.ShapeRange(shapeCount).Height / 2
    
    ' Calculate the space between the shapes
    spaceBetween = (maxY - minY) / (oSel.ShapeRange.Count - 1)

    ' Distribute the shapes vertically
    For i = 2 To oSel.ShapeRange.Count
        oSel.ShapeRange(i).Top = oSel.ShapeRange(i - 1).Top + oSel.ShapeRange(i - 1).Height / 2 + spaceBetween - oSel.ShapeRange(i).Height / 2
    Next i


End Sub

I tried use ChatGPT to find problem but without a success

Answer 1

Try this -pushed out the sorting to a separate method

Sub DistributeShapesVerticallyv2()
    
    Dim oShp As Shape, theShapes As New Collection
    Dim oSld As Slide, oSel As Selection, arr
    Dim minY As Single, maxY As Single, spaceBetween As Single

    Set oSld = ActiveWindow.View.Slide ' Get the current slide and selection
    Set oSel = ActiveWindow.Selection

    If oSel.Type <> ppSelectionShapes Or oSel.ShapeRange.Count < 2 Then
        MsgBox "Please select at least two shapes to distribute vertically."
        Exit Sub
    End If
    'collect all selected shapes and their vertical centers
    For Each oShp In oSel.ShapeRange
        theShapes.Add Array(oShp, oShp.Top + oShp.Height / 2)
    Next oShp
    SortCollection theShapes, 2 'sort the collection of arrays
    minY = theShapes(1)(1)
    maxY = theShapes(theShapes.Count)(1)
    spaceBetween = (maxY - minY) / (theShapes.Count - 1)
    'loop shapes top to bottom and space out
    For Each arr In theShapes
        arr(0).Top = minY - (arr(0).Height / 2)
        minY = minY + spaceBetween
    Next arr

End Sub

'Sort a collection of 0-based arrays in ascending order by the n'th element of each array
    'Adapted from https://stackoverflow.com/a/3588073/478884
Sub SortCollection(col As Collection, n As Long)
    Dim i As Long, j As Long, vTemp As Variant
    For i = 1 To col.Count - 1 'Two loops to bubble sort
        For j = i + 1 To col.Count
            If col(i)(n - 1) > col(j)(n - 1) Then  'change to < for descending sort
                vTemp = col(j)                     'store the item
                col.Remove j                       'remove the item
                col.Add Item:=vTemp, before:=i     're-add the item before the comparator
            End If
        Next j
    Next i
End Sub