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. : pray2:

code:

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

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

Code:

---

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

---

Quote:

---

Originally Posted by John Wilson

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

Code:

---

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?

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!

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

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

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

Code:

---

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

---

Added some refinement to first version

Code:

---

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

Code:

---

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

Code:

---

    If S1.Left => S2.Left Then

---

Attaching the sample presentation I am trying and error I am getting.

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

Attachment 25100

Let me play a bit

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

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

Try this version

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

Quote:

---

Originally Posted by Paul_Hossler

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).

John Wilson is the PP expert here

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

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

Code:

---


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

 


---

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

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

Code:

---


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

 


---

---

The 2 boxes don't overlap - they just touch.

I added something for that

Code:

---

    '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

Attachment 25108

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

Attachment 25109

Try changing the line to

Code:

---

    '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' :)

Quote:

---

Originally Posted by Paul_Hossler

Try changing the line to

Code:

---

    '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.

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

Quote:

---

Hello Paul, I am including something like:

If S1.bottom falls anywhere between (S2.Top and S2.Top + 0.5). Because the shapes seems like touching but they are little away but close enough (creating an illusion). is there any effective way to check for this, can using of multiple operators cause problem?

---

I used .5 as a tolerance from your PM, but you might have to adjust it to establish your own 'close enough'

What is shape1.top + shape1.height?

what is shape2.top?

What is the difference?

Attach a sample PP if you want


Edit

ver 3 has close shapes and a msgbox macro to show measurements

ver 4 has different tolerances to define close (i.e 2 instead of .5)

I don't see the behavior in your #19, so attach an example and I'll look

Quote:

---

Originally Posted by Paul_Hossler

I used .5 as a tolerance from your PM, but you might have to adjust it to establish your own 'close enough'

What is shape1.top + shape1.height?

what is shape2.top?

What is the difference?

Attach a sample PP if you want


Edit

ver 3 has close shapes and a msgbox macro to show measurements

ver 4 has different tolerances to define close (i.e 2 instead of .5)

I don't see the behavior in your #19, so attach an example and I'll look

---

Attaching the sample Paul. Thank you.

I had to change my definition of 'close' to determine if 2 shapes overlapped. I assumed that each shape was +2 up, left, down and right and then checked against these slightly larger shapes

Seem to work better in your case

Tolerance =2 but you can change that

Ingenious Paul!! I thought this is Impossible but you people made it easier to solve. Thanks a lot:bow:. This is new and I will learn it. I am just curious what is 'test' for in pp you attached?

Quote:

---

Originally Posted by Paul_Hossler

I had to change my definition of 'close' to determine if 2 shapes overlapped. I assumed that each shape was +2 up, left, down and right and then checked against these slightly larger shapes

Seem to work better in your case

Tolerance =2 but you can change that

---

'Test' is a throw-away macro I wrote when I was investigating why some shapes would group when I didn't expect them to

You can delete the entire standard module

Code:

---

Option Explicit


Sub test()
    Dim s As String
    Dim S1 As Dimensions, S2 As Dimensions


    With ActivePresentation.Slides(1)
        S1 = GetDimensions(.Shapes("myShape1"))
        S2 = GetDimensions(.Shapes("myShape2"))
       
        s = "S1 Top = " & S1.Top & vbCrLf & "s1.Height = " & S1.Height & vbCrLf & "S2 Top = " & S2.Top & vbCrLf
        s = s & "Gap = " & (S1.Top + S1.Height - S2.Top)


        MsgBox s
    End With


End Sub

---

Perfect! Thank you.

Quote:

---

Originally Posted by Paul_Hossler

'Test' is a throw-away macro I wrote when I was investigating why some shapes would group when I didn't expect them to

You can delete the entire standard module

Code:

---

Option Explicit


Sub test()
    Dim s As String
    Dim S1 As Dimensions, S2 As Dimensions


    With ActivePresentation.Slides(1)
        S1 = GetDimensions(.Shapes("myShape1"))
        S2 = GetDimensions(.Shapes("myShape2"))
       
        s = "S1 Top = " & S1.Top & vbCrLf & "s1.Height = " & S1.Height & vbCrLf & "S2 Top = " & S2.Top & vbCrLf
        s = s & "Gap = " & (S1.Top + S1.Height - S2.Top)


        MsgBox s
    End With


End Sub

---

---

Here's a more cleaned up 'production' ready version

This was a fun little project

Sure! Thank Paul. you are a Gem!! A light in dark tunnel.

Quote:

---

Originally Posted by Paul_Hossler

Here's a more cleaned up 'production' ready version

This was a fun little project

---

Thanks John and other contributors for helping people for no reason. Thanks VBA express team!