Snap to Shape

Hello,

I am searching for a code which can make two shapes stick to each other in PPT.
Please can someone help me with a code to stick two or more selected shapes together.

Attachment 24154

Thanks

By "stick to ... " Do you just mean align as in the diagram?

TRY:

Code:

---

Sub stickem_V()
    Dim rayShp() As Shape
    Dim L As Long
    ReDim rayShp(1 To ActiveWindow.Selection.ShapeRange.Count)
    For L = 1 To ActiveWindow.Selection.ShapeRange.Count
        Set rayShp(L) = ActiveWindow.Selection.ShapeRange(L)
    Next L
    Call SortByTop(rayShp)
    For L = 2 To UBound(rayShp)
        With rayShp(L - 1)
            rayShp(L).Top = .Top + .Height
        End With
    Next L
End Sub
Sub SortByTop(Arrayin As Variant)
    Dim b_Cont As Boolean
    Dim lngCount As Long
    Dim vSwap As Shape
    Do
        b_Cont = False
        For lngCount = LBound(Arrayin) To UBound(Arrayin) - 1
            If Arrayin(lngCount).Top > Arrayin(lngCount + 1).Top Then
                Set vSwap = Arrayin(lngCount)
                Set Arrayin(lngCount) = Arrayin(lngCount + 1)
                Set Arrayin(lngCount + 1) = vSwap
                b_Cont = True
            End If
        Next lngCount
    Loop Until Not b_Cont
    'release objects
    Set vSwap = Nothing
End Sub

---

Wow... this works perfect. Thank you so much John, you are awesome.