Align shapes flush/stacked/touching

[michaelhaag]

Hello,
I'm trying to get a selection of shapes in order from right to left. I found a routine by John Wilson on vbaexpress on which I based my code.


The sorting works perfectly when I select item by item by clicking on the shapes but it doesn't respect the "visible order" of shapes if I select them by "lassoing" with my mouse.


In case of dragging my mouse over the shapes to select them, the routine should respect the visible order of shapes.


Thanks in advance.

[Aussiebear]

A quick search on Google suggests that you might be able to do the following

1. Grouping:

• Simple and Effective:
  
  • After lassoing your shapes, immediately press Ctrl+G (or right-click and select "Group"). This turns your selected shapes into a single object.
    
    
    
    
  • Now, you can move, resize, and rotate the entire group while preserving the relative positions of the individual shapes within it.
    
    
    
    
  • To edit individual shapes later, right-click the group and select "Ungroup."

[medarda]

To align PowerPoint shapes flush and in the correct visible order when selecting with a lasso, you'll need to sort the shapes based on their positions rather than relying on the selection order.

Sub AlignShapesFlush()    
    Dim shp As Shape
    Dim shpArray As Object
    Dim i As Integer, j As Integer
    Dim temp As Shape
    Dim slide As slide    
    Set slide = ActiveWindow.View.Slide    
    ' Store selected shapes in an array
    Set shpArray = CreateObject("Scripting.Dictionary")
    For Each shp In ActiveWindow.Selection.ShapeRange
        shpArray.Add shpArray.Count, shp
    Next shp    
    ' Sort shapes from right to left (by .Left position descending)
    For i = 0 To shpArray.Count - 2
        For j = i + 1 To shpArray.Count - 1
            If shpArray(i).Left < shpArray(j).Left Then
                Set temp = shpArray(i)
                Set shpArray(i) = shpArray(j)
                Set shpArray(j) = temp
            End If
        Next j
    Next i    
    ' Align shapes touching each other (flush)
    Dim currentLeft As Single
    currentLeft = shpArray(0).Left + shpArray(0).Width ' Start at the rightmost shape
    For i = 1 To shpArray.Count - 1
        shpArray(i).Left = currentLeft
        currentLeft = shpArray(i).Left + shpArray(i).Width
    Next i    
    ' Cleanup
    Set shpArray = Nothing
    Set slide = Nothing
End Sub