Consulting

Page 1 of 2 1 2 LastLast
Results 1 to 20 of 29

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,870
    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,870
    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

  7. #7
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    OK, this is the best I could come up with

    All I can say is that it works on my test case:

    1 stand alone shape
    2 overlapping
    3 overlapping



    Option Explicit
    
    
    Sub GroupOverlappingShapes()
        Dim oPres As Presentation
        Dim oSlide As Slide
        Dim oShape1 As Shape, oShape2 As Shape
        Dim iShape1 As Long, iShape2 As Long
        Dim bDone As Boolean
        Dim vGroupedShapes() As String
        Dim i As Long
        
        Set oPres = ActivePresentation
        
        For Each oSlide In oPres.Slides
            With oSlide
            
                bDone = False
            
                Do While Not bDone
                
                    bDone = True
                    
                    For iShape1 = 1 To .Shapes.Count - 1
                        For iShape2 = iShape1 + 1 To .Shapes.Count
                            
                            Set oShape1 = .Shapes(iShape1)
                            Set oShape2 = .Shapes(iShape2)
                        
    '                        Debug.Print "Shape1 = " & oShape1.Name & " --  Shape2 = " & oShape2.Name
    '                        Stop
                        
                            If Not ShapesOverlap(oShape1, oShape2) Then GoTo NextShape2
                               
                            If oShape1.Type = msoGroup Then
                                Erase vGroupedShapes
                                ReDim vGroupedShapes(1 To oShape1.GroupItems.Count + 1)
                            
                                For i = 1 To oShape1.GroupItems.Count
                                    vGroupedShapes(i) = oShape1.GroupItems(i).Name
                                Next i
                                vGroupedShapes(oShape1.GroupItems.Count + 1) = oShape2.Name
                                
                                oShape1.Ungroup
                                
                                oSlide.Shapes.Range(vGroupedShapes).Group
                                
                                bDone = False
                                GoTo LoopAgain
                            
                            Else
                                oSlide.Shapes.Range(Array(oShape1.Name, oShape2.Name)).Group
                                bDone = False
                                GoTo LoopAgain
                           End If
                           
    NextShape2:
                       Next iShape2
                   Next iShape1
        
    LoopAgain:
                Loop
            End With
        Next
    
    
    End Sub
    
    
    'https://stackoverflow.com/questions/9003696/how-to-find-out-if-two-textboxes-or-shapes-overlap-using-vba-in-powerpoint-2007
    Function ShapesOverlap(oSh1 As Shape, oSh2 As Shape) As Boolean
        Dim Shp1Left As Single
        Dim Shp1Right As Single
        Dim Shp1Top As Single
        Dim Shp1Bottom As Single
    
    
        Dim Shp2Left As Single
        Dim Shp2Right As Single
        Dim Shp2Top As Single
        Dim Shp2Bottom As Single
    
    
        Dim bHorizontalOverlap As Boolean
        Dim bVerticalOverlap As Boolean
    
    
        With oSh1
            Shp1Left = .Left
            Shp1Right = .Left + .Width
            Shp1Top = .Top
            Shp1Bottom = .Top + .Height
        End With
    
    
        With oSh2
            Shp2Left = .Left
            Shp2Right = .Left + .Width
            Shp2Top = .Top
            Shp2Bottom = .Top + .Height
        End With
    
    
        ' do they overlap horizontally?
        If Shp1Left > Shp2Left Then
            If Shp1Left < Shp2Right Then
                bHorizontalOverlap = True
            End If
        End If
        If Shp1Left < Shp2Left Then
            If Shp1Right > Shp2Left Then
                bHorizontalOverlap = True
            End If
        End If
    
    
        ' do they overlap vertically?
        If Shp1Top > Shp2Top Then
            If Shp1Top < Shp2Bottom Then
                bVerticalOverlap = True
            End If
        End If
        ' do they overlap vertically?
        If Shp1Top < Shp2Top Then
            If Shp1Bottom > Shp2Top Then
                bVerticalOverlap = True
            End If
        End If
    
    
        ShapesOverlap = bHorizontalOverlap And bVerticalOverlap
    
    
    End Function
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  8. #8
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    Added some refinement to first version


    Option Explicit
    
    
    Sub GroupOverlappingShapes()
        Dim oPres As Presentation
        Dim oSlide As Slide
        Dim oShape1 As Shape, oShape2 As Shape
        Dim iShape1 As Long, iShape2 As Long
        Dim bDone As Boolean
        Dim vGroupedShapes() As String
        Dim i As Long
        
        Set oPres = ActivePresentation
        
        For Each oSlide In oPres.Slides
            With oSlide
            
                'Ungroup any shapes
                bDone = False
                
                Do While Not bDone
                
                    bDone = True
                    
                    For iShape1 = 1 To .Shapes.Count
                        Set oShape1 = .Shapes(iShape1)
                    
                        If oShape1.Type = msoGroup Then
                            oShape1.Ungroup
                            bDone = False
                            GoTo Loopagain2
                        End If
                    Next iShape1
    Loopagain2:
                Loop
            
                
                'now group overlapping shapes
                bDone = False
            
                Do While Not bDone
                
                    bDone = True
                    
                    For iShape1 = 1 To .Shapes.Count - 1
                        For iShape2 = iShape1 + 1 To .Shapes.Count
                            
                            Set oShape1 = .Shapes(iShape1)
                            Set oShape2 = .Shapes(iShape2)
                        
                            If Not ShapesOverlap(oShape1, oShape2) Then GoTo NextShape2
                               
                            If oShape1.Type = msoGroup Then
                                Erase vGroupedShapes
                                ReDim vGroupedShapes(1 To oShape1.GroupItems.Count + 1)
                            
                                For i = 1 To oShape1.GroupItems.Count
                                    vGroupedShapes(i) = oShape1.GroupItems(i).Name
                                Next i
                                vGroupedShapes(oShape1.GroupItems.Count + 1) = oShape2.Name
                                
                                oShape1.Ungroup
                                
                                oSlide.Shapes.Range(vGroupedShapes).Group
                                
                                bDone = False
                                GoTo LoopAgain
                            
                            Else
                                Erase vGroupedShapes
                                ReDim vGroupedShapes(1 To 2)
                                
                                vGroupedShapes(1) = oShape1.Name
                                vGroupedShapes(2) = oShape2.Name
                            
                                oSlide.Shapes.Range(vGroupedShapes).Group
                                bDone = False
                                GoTo LoopAgain
                           End If
                           
    NextShape2:
                       Next iShape2
                   Next iShape1
        
    LoopAgain:
                Loop
            End With
        Next
    
    
    End Sub

    and


    Option Explicit
    
    
    Type Dimensions
        Left As Single
        Right As Single
        Top As Single
        Bottom As Single
        Height As Single
        Width As Single
    End Type
    
    
    'https://stackoverflow.com/questions/9003696/how-to-find-out-if-two-textboxes-or-shapes-overlap-using-vba-in-powerpoint-2007
    Function ShapesOverlap(oSh1 As Shape, oSh2 As Shape) As Boolean
        Dim S1 As Dimensions, S2 As Dimensions
        Dim bHorizontalOverlap As Boolean, bVerticalOverlap As Boolean
    
    
        S1 = GetDimensions(oSh1)
        S2 = GetDimensions(oSh2)
        
        ' do they overlap horizontally?
        If S1.Left > S2.Left Then
            If S1.Left < S2.Right Then bHorizontalOverlap = True
        ElseIf S1.Left < S2.Left Then
            If S1.Right > S2.Left Then bHorizontalOverlap = True
        End If
    
    
        ' do they overlap vertically?
        If S1.Top > S2.Top Then
            If S1.Top < S2.Bottom Then bVerticalOverlap = True
        ElseIf S1.Top < S2.Top Then
            If S1.Bottom > S2.Top Then bVerticalOverlap = True
        End If
    
    
        ShapesOverlap = (bHorizontalOverlap And bVerticalOverlap)
    
    
    End Function
    
    
    Private Function GetDimensions(oShape As Shape) As Dimensions
        With GetDimensions
            .Left = oShape.Left
            .Right = oShape.Left + oShape.Width
            .Top = oShape.Top
            .Bottom = oShape.Top + oShape.Height
            .Height = oShape.Height
            .Width = oShape.Width
        End With
    End Function

    I'm still trying to decide how to handle the overlap test if (for ex) .Top1 = .Top2

    I think I want to do something like

        If S1.Left => S2.Left Then
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  9. #9
    Attaching the sample presentation I am trying and error I am getting.
    Attached Images Attached Images
    Attached Files Attached Files

  10. #10
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    Actually, I thought you'll only get that message if there are PlaceHolders, and you didn't seem to have any

    However, PP does allow shapes to have the same names, and I think that's what's going on here

    Capture.JPG

    Let me play a bit

    I think I'll add a serial number suffix to each shape and then group
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  11. #11
    Sure, thanks Paul. I guess rename function might help us to set unique values to shapes.

  12. #12
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    Try this version

    The weak spot is the Connectors, since they sort of are in multiple groups
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  13. #13
    Quote Originally Posted by Paul_Hossler View Post
    Try this version

    The weak spot is the Connectors, since they sort of are in multiple groups
    Thanks so much Paul. Can this be applied for text boxes or pictures that are piled up on shapes or is there any restrictions (like, what pp doesn't support regarding connectors).

  14. #14
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    John Wilson is the PP expert here

    He might know, but try different types of shapes and report back
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  15. #15
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    I moved some logic into a separate function, and specified the types of shapes that I considered Group-able

    It includes Textboxes and Pictures, but not Connectors. Those you can do manually



    
    Private Function pvtGroupAble(shp As Shape) As Boolean
        pvtGroupAble = False
        
        Select Case shp.Type
            Case msoAutoShape
                If shp.AutoShapeType <> msoShapeMixed Then pvtGroupAble = True
            Case msoGroup, msoTextBox, msoPicture
                pvtGroupAble = True
        End Select
    End Function
    
     
    
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  16. #16
    You are genius Paul! Thanks for your patience and effort. This solved my problem 99%. I am attaching ppt with two issues(slide 3 and 4), I am facing (not being skeptical). Just if you can input any thoughts if possible. thanks again Paul.
    Quote Originally Posted by Paul_Hossler View Post
    I moved some logic into a separate function, and specified the types of shapes that I considered Group-able

    It includes Textboxes and Pictures, but not Connectors. Those you can do manually



    
    Private Function pvtGroupAble(shp As Shape) As Boolean
        pvtGroupAble = False
        
        Select Case shp.Type
            Case msoAutoShape
                If shp.AutoShapeType <> msoShapeMixed Then pvtGroupAble = True
            Case msoGroup, msoTextBox, msoPicture
                pvtGroupAble = True
        End Select
    End Function
    
     
    
    Attached Files Attached Files

  17. #17
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    The 2 boxes don't overlap - they just touch.

    I added something for that

        'do they touch
        If S1.Bottom = S2.Top Or S1.Top = S2.Bottom Or S1.Left = S2.Right Or S1.Right = S2.Left Then
            ShapesOverlap = True
            Exit Function
        End If
    I can't make the connectors hidden

    If the background rectangle is there before running the macro, everything is grouped under it

    Capture.JPG

    If you run the macro first without it, the overlapping/touching shapes are grouped. Adding the large rectangle and then "Send to Back" still shows the connectors

    Capture2.JPG
    Attached Files Attached Files
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  18. #18
    VBAX Wizard
    Joined
    Apr 2007
    Posts
    6,718
    Location
    Try changing the line to


        'do they touch
        If Abs(S1.Bottom - S2.Top) <= 0.5 Or Abs(S1.Top - S2.Bottom) <= 0.5 Or Abs(S1.Left - S2.Right) <= 0.5 Or Abs(S1.Right - S2.Left) <= 0.5 Then
            ShapesOverlap = True
            Exit Function
        End If

    to define 'touching' as 'close enough'
    Paul

    ------------------------------------------------------------------------------------------------------------------------
    1. Use [CODE] ....[/CODE ] Tags for readability
    [CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
    2. Upload an example
    Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s)
    (multiple files can be selected while holding Ctrl key) / Upload Files / Done
    3. Mark the thread as [Solved] when you have an answer
    Thread Tools (on the top right corner, above the first message)
    4. Read the Forum FAQ, especially the part about cross-posting in other forums
    http://www.vbaexpress.com/forum/faq...._new_faq_item3

  19. #19
    Quote Originally Posted by Paul_Hossler View Post
    Try changing the line to


        'do they touch
        If Abs(S1.Bottom - S2.Top) <= 0.5 Or Abs(S1.Top - S2.Bottom) <= 0.5 Or Abs(S1.Left - S2.Right) <= 0.5 Or Abs(S1.Right - S2.Left) <= 0.5 Then
            ShapesOverlap = True
            Exit Function
        End If

    to define 'touching' as 'close enough'
    It is working differently. Following is happening:
    For example if group 1, group 2 are sets that already exist, these are grouped as group 3 but shapes in group 1, group 2 are regrouped now.
    Attached Images Attached Images

  20. #20
    If shapes are this close (as in picture) they are not grouped, where as if either of dimensions touch they are grouped.
    Attached Images Attached Images

Posting Permissions

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