How to code a PowerPoint VBA Macro that “stacks” shapes on top of/touching each other?

Question

I'm trying to find a way to make a macro that "stacks" shapes right next to each other, sort of like how a totem pole is stacked, with the shapes basically touching each other. The idea here is that it would be really helpful for items like chevron timelines, or making sure that shapes are as close as they can be without overlapping.

So far, my code thought process has been something like this, assuming that I want to stack from the bottom up:

Select all shapes

For shapes in the selection:

Collect the bottom position and top position of each shape

Using the lowest shape as a reference, place the second lowest shape at position (lowest shape coordinates minus shape height)

Using the second lowest shape as a reference, place the third lowest shape at position (second lowest shape minus second lowest shape height)

And so on until all the shapes are stacked on top of each other. I imagine the code could be easily modified for stacking top to bottom, or stacking left to right.

Biggest question is, how do I make this code? I've gone through the tutorials on how to move objects, but I can't seem to get it to do it with more than two objects.

Here's what I've got so far:

Sub Stack_on_top()
Dim Shp1 As Shape
Dim Shp2 As Shape
Dim x As Integer
Dim y As Integer

  x = Windows(1).Selection.ShapeRange.Count
  For y = 1 To x
    If Shp1 Is Nothing Then
      Set Shp1 = Windows(1).Selection.ShapeRange(y)
    Else
      Set Shp2 = Windows(1).Selection.ShapeRange(y)
          Shp2.Top = Shp1.Top - Shp2.Height
      End If
  Next y
End Sub

Problem is, this code only does it with 2 objects, the rest just stack based off of the one reference. Any help would be highly appreciated!

Thanks!

-John

Steve Rindsberg Steve Rindsberg · Accepted Answer · 2020-04-20T02:47:35

Try like so:

Sub Stack_on_top()

Dim Shp1 As Shape
Dim Shp As Shape
Dim x As Long
Dim sngLastY As Single

    Set Shp1 = ActiveWindow.Selection.ShapeRange(1)
    sngLastY = Shp1.Top

    For x = 2 To ActiveWindow.Selection.ShapeRange.Count
        Set Shp = ActiveWindow.Selection.ShapeRange(x)
        With Shp
            .Left = Shp1.Left
            .Top = sngLastY - .Height
            sngLastY = .Top
        End With
    Next

End Sub

[Later ... adding shapes to array]

Function SelectedShapesToArray(ShRange As ShapeRange) As Variant

    Dim aTemparray() As Shape
    ReDim aTemparray(1 To ShRange.Count)
    Dim x As Long

    For x = 1 To ShRange.Count
        Set aTemparray(x) = ShRange(x)
    Next

    SelectedShapesToArray = aTemparray

End Function

Sub Test()

    Dim x As Long
    Dim ShArray() As Shape

    ShArray = SelectedShapesToArray(ActiveWindow.Selection.ShapeRange)

    ' Test: do we have all the shapes we expected?
    For x = LBound(ShArray) To UBound(ShArray)
        Debug.Print ShArray(x).Name
    Next

    ' Here you could sort ShArray on ShArray(x).top

End Sub

How to code a PowerPoint VBA Macro that “stacks” shapes on top of/touching each other?

1 Answers