Consulting

Results 1 to 5 of 5

Thread: Macro to set the exact space between shapes

  1. #1
    VBAX Newbie
    Joined
    Jul 2015
    Posts
    1
    Location

    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

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,943
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    VBAX Newbie
    Joined
    Nov 2020
    Posts
    4
    Location
    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
    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

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,943
    Location
    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
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    VBAX Newbie
    Joined
    Nov 2020
    Posts
    4
    Location
    Thank you so much John, it works perfectly

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •