Macro to set the exact space between shapes

[g_rotily]

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

[John Wilson]

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


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

[clemleb]

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

[John Wilson]

Try

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

[clemleb]

Thank you so much John, it works perfectly :thumb

[SamT]

Thread is closed. See: http://www.vbaexpress.com/forum/showthread.php?68811-Use-the-macro-for-all-the-images-on-all-slides&p=409613#post409613
For more info.