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

Did you try asking ChatGPT why it does not work well from logical perspective in all usecases? — braX, Apr 26 '23 at 11:52
I tried several times with chatGPT 4.0 but without a success I think the issue is with sorting loop — Bartek, Apr 26 '23 at 13:30
"it does not work well from logical perspective in all usecases" - what use cases specifically? It's easier if we don't have to guess... — Tim Williams, Apr 26 '23 at 15:32
There is no errors, just the matter that in most usecases it reordes shapes not using the full high between the top one and bottom one. I think that the loop is not working well, so the elements are not properly arranged and identified. However, it is hard to track (at least for me), as there are not a lot of visual things happening if you track step by step what the code is doing — Bartek, Apr 26 '23 at 15:46

score 1 · Accepted Answer · answered Apr 26 '23 at 15:53

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

thanks a lot. Working like a charm (at least in initial testing). You rock! — Bartek, Apr 26 '23 at 16:34

score 0 · Answer 2 · answered Apr 26 '23 at 17:26

Here is a code to do the same but horizontally

Public Sub DistributeHorizontally(control As IRibbonControl)

'distribute slected shapes horizontaly based on the shapes' centres

Dim oShp As Shape, theShapes As New Collection
Dim oSld As Slide, oSel As Selection, arr
Dim minX As Single, maxX 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 horizontally."
    Exit Sub
End If
'collect all selected shapes and their vertical centers
For Each oShp In oSel.ShapeRange
    theShapes.Add Array(oShp, oShp.Left + oShp.Width / 2)
Next oShp
SortCollection theShapes, 2 'sort the collection of arrays
minX = theShapes(1)(1)
maxX = theShapes(theShapes.Count)(1)
spaceBetween = (maxX - minX) / (theShapes.Count - 1)
'loop shapes top to bottom and space out
For Each arr In theShapes
    arr(0).Left = minX - (arr(0).Width / 2)
    minX = minX + spaceBetween
Next arr

End Sub

Vertical distibution of slected shapes by shapes centres in PowerPoint

2 Answers2