Macro to set the exact space between shapes

Hello,

I am looking for a macro that will allow me to set/determine the space between several shapes on powerpoint.

Once I have distributed (vertically or horizontally) some shapes on ppt, then the space between these shapes is equal.

But I want to determine that the space between these shapes is not only equal but also choose the exact size of this space (e.g. 1cm or 5cm).

I could not find a ppt command to do this, nor a macro.

I am very surprised as this would be so useful. Could some of you experts give a try at writing this macro?

Many thanks to those who try to help me!

Gab

It's not clear how much experience you have. It is not as straightforward as you might imaging.

PPT only works in POINTS in code so a conversion function is needed
It is difficult to ensure the shapes are selected in the correct order so a sort routine is a good idea

Code:

---

Sub set_gap()
Dim sngGap As Single
Dim rayShapes() As Shape
Dim L As Long
On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
MsgBox "Select at least 2 shapes"
Exit Sub
End If
On Error GoTo 0
ReDim rayShapes(1 To ActiveWindow.Selection.ShapeRange.Count)
sngGap = cm2Points(2) ' 2 cm gap
For L = 1 To ActiveWindow.Selection.ShapeRange.Count
Set rayShapes(L) = ActiveWindow.Selection.ShapeRange(L)
Next L
' make sure selected shapes are sorted by left value
Call SortByLeft(rayShapes)
' set the gap
For L = 2 To UBound(rayShapes)
Debug.Print rayShapes(L).Name
rayShapes(L).Left = rayShapes(L - 1).Left + rayShapes(L - 1).Width + sngGap
Next L
End Sub

Sub SortByLeft(Arrayin As Variant)
' sort the shapes based on their left value
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
        Debug.Print Arrayin(lngCount).Name
        If Arrayin(lngCount).Left > Arrayin(lngCount + 1).Left 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

Function cm2Points(inVal As Single) As Single
'convert cm to points
cm2Points = inVal * 28.346
End Function

---

Dear John,

Thank you very much for this useful macro, It's my first time using macros and I tried to change the value to 0.25cm with success :yes
I would love to have the same macro for vertical space, it would be very appreciated to create a perfect grid with object or images.

Thank you very much for your help

Try

Code:

---

Sub set_Vert_gap()
Dim sngGap As Single
Dim rayShapes() As Shape
Dim L As Long
On Error Resume Next
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
MsgBox "Select at least 2 shapes"
Exit Sub
End If
On Error GoTo 0
ReDim rayShapes(1 To ActiveWindow.Selection.ShapeRange.Count)
sngGap = cm2Points(2) ' 2 cm gap
For L = 1 To ActiveWindow.Selection.ShapeRange.Count
Set rayShapes(L) = ActiveWindow.Selection.ShapeRange(L)
Next L
' make sure selected shapes are sorted by top value
Call SortByTop(rayShapes)
' set the gap
For L = 2 To UBound(rayShapes)
Debug.Print rayShapes(L).Name
rayShapes(L).Top = rayShapes(L - 1).Top + rayShapes(L - 1).Height + sngGap
Next L
End Sub


Sub SortByTop(Arrayin As Variant)
' sort the shapes based on their left value
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
        Debug.Print Arrayin(lngCount).Name
        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


Function cm2Points(inVal As Single) As Single
'convert cm to points
cm2Points = inVal * 28.346
End Function

---

Thank you so much John, it works perfectly :thumb

Thread is closed. See: http://www.vbaexpress.com/forum/show...613#post409613
For more info.