Consulting

Results 1 to 6 of 6

Thread: Grouping of shapes in PowerPoint VBA

  1. #1

    Grouping of shapes in PowerPoint VBA

    Hello,


    I am trying to group multiple shapes in a slide without using selection. Following is snippet I am working on but the problem is, each time I have to select shapes that are to be grouped and then run macro which is similar to manually grouping by using builtin feature.

    My idea is to 1. select all ( ctr+ A) and run macro or
    2. To detect shapes that needs to be grouped and collect them into range or array and then utilize grouping method.
    To detect shapes - A condition that checks for overlapping or touching of shapes and consider them as shapes that are to be grouped.
    I am not sure how can this be done. Any thoughts on this is really helpful.

    code:

    Sub Grouping() ActiveWindow.Selection.ShapeRange.Group
    ' A code which can avoid task of selecting shapes
    End Sub
    Attached Images Attached Images

  2. #2
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,863
    Location
    That will be a tricky project!

    Here is how to group shapes on a slide that are Blue (RGB(68, 114, 196) which might give you some pointers

    Sub Grouper()
    Dim rayBlue() As Long
    Dim osld As Slide
    Dim L As Long
    ReDim rayBlue(1 To 1)
    Set osld = ActivePresentation.Slides(1)
    For L = 1 To osld.Shapes.Count
    If osld.Shapes(L).Fill.ForeColor.RGB = RGB(68, 114, 196) Then
    rayBlue(UBound(rayBlue)) = L
    ReDim Preserve rayBlue(1 To UBound(rayBlue) + 1)
    End If
    Next L
    'Remove last unwanted blank
    ReDim Preserve rayBlue(1 To UBound(rayBlue) - 1)
    ActivePresentation.Slides(1).Shapes.Range(rayBlue).Group
    End Sub
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  3. #3
    Quote Originally Posted by John Wilson View Post
    That will be a tricky project!

    Here is how to group shapes on a slide that are Blue (RGB(68, 114, 196) which might give you some pointers

    Sub Grouper()
    Dim rayBlue() As Long
    Dim osld As Slide
    Dim L As Long
    ReDim rayBlue(1 To 1)
    Set osld = ActivePresentation.Slides(1)
    For L = 1 To osld.Shapes.Count
    If osld.Shapes(L).Fill.ForeColor.RGB = RGB(68, 114, 196) Then
    rayBlue(UBound(rayBlue)) = L
    ReDim Preserve rayBlue(1 To UBound(rayBlue) + 1)
    End If
    Next L
    'Remove last unwanted blank
    ReDim Preserve rayBlue(1 To UBound(rayBlue) - 1)
    ActivePresentation.Slides(1).Shapes.Range(rayBlue).Group
    End Sub

    Thanks John! This input is so valuable. Yes this is so tricky and a good challenge for me. I will try to replace IF condition to check to boundary condition of shapes (left , top, bottom , right - few calculations) that are touching or overlapping each other and if Boolean is true the shape(some iterations) is inserted into array. Later perform group method on that array. Is this practical and achievable as per your knowledge?

  4. #4
    VBAX Master
    Joined
    Feb 2007
    Posts
    1,863
    Location
    I would say it is possible but tricky. You would have to look at the first shape, find others that fill the criteria and add to the array. Group and look again for another ungrouped shape and repeat until no more suitable matches are found.

    After each "run" you would need to clear the array or use a new array.

    You clear the array by ReDim raywhatever(1 to 1)

    Interesting challenge!
    John Wilson
    Microsoft PowerPoint MVP
    Amazing Free PowerPoint Tutorials
    http://www.pptalchemy.co.uk/powerpoi...tutorials.html

  5. #5
    Hello,

    I found few online resources that can help one approach. I am trying to use overlap shape function instead of intersect function (as PowerPoint doesn't support this function). Please help!
    https://www.thespreadsheetguru.com/t...ction-of-cells - main sub procedure
    https://stackoverflow.com/questions/...owerpoint-2007 - shape overlap function

  6. #6
    This is the code I tried to solve this problem. But, not sure how to polish this so that it works perfectly. Could anyone please suggest modifications so that my code works fine. I used overlap function to check boundary conditions form the source :
    https://stackoverflow.com/questions/...owerpoint-2007 - shape overlap function

    Sub Grouping()
    Dim V AsLong
    Dim oSh1 As Shape
    Dim oSh2 As Shape
    Dim Shapesarray()As Shape
    OnErrorResumeNext
    If ActiveWindow.Selection.ShapeRange.Count <2Then
    MsgBox
    "Select at least 2 shapes"
    ExitSub
    EndIf
    ReDim Shapesarray(1To ActiveWindow.Selection.ShapeRange.Count)' maximum
    array size
    = no.of shapes selected, dynamic array
    For V =1To ActiveWindow.Selection.ShapeRange.Count
    ' A condition to check boundary conditions and add shape into array if it is true.

    Set oSh1 = ActiveWindow.Selection.ShapeRange(V)
    Set oSh2 = ActiveWindow.Selection.ShapeRange(V +1)

    If ShapesOverlap(oSh1, oSh2)=TrueThen

    ' boundary conditions AND shape type is not a connector
    ' the next shape it is going to add should be atleast nearby the present
    shape
    ,if so add into array or group current array anderase contents in
    that array
    Set Shapesarray(V)= oSh1
    Set Shapesarray(V +1)= oSh2
    'else move to next shape in selction range and check
    EndIf
    ' group items in array

    Range
    (Shapesarray).Group ' Grouping all the elements of the array
    V
    = V +1
    Next V
    ' at last remaining shapes in shape collection are grouped all together

    End Sub

Posting Permissions

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