Grouping of shapes in PowerPoint VBA

[CuriosityBug]

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

[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


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

[CuriosityBug]

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?

[John Wilson]

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!

[CuriosityBug]

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/the-code-vault/group-all-shapes-within-a-selection-of-cells - main sub procedure
https://stackoverflow.com/questions/9003696/how-to-find-out-if-two-textboxes-or-shapes-overlap-using-vba-in-powerpoint-2007 - shape overlap function

[CuriosityBug]

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 (https://stackoverflow.com/questions/9003696/how-to-find-out-if-two-textboxes-or-shapes-overlap-using-vba-in-powerpoint-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

[Paul_Hossler]

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

[Paul_Hossler]

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

[CuriosityBug]

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

[Paul_Hossler]

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

25100

Let me play a bit

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

[CuriosityBug]

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

[Paul_Hossler]

Try this version

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

[CuriosityBug]

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

[Paul_Hossler]

John Wilson is the PP expert here

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

[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






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

[CuriosityBug]

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.

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

[Paul_Hossler]

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

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

25109

[Paul_Hossler]

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

[CuriosityBug]

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.

[CuriosityBug]

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

[Paul_Hossler]

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

[CuriosityBug]

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.

[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

[CuriosityBug]

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?



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

[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



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

[CuriosityBug]

Perfect! Thank you.

'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



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

[Paul_Hossler]

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

This was a fun little project

[CuriosityBug]

Sure! Thank Paul. you are a Gem!! A light in dark tunnel.
Here's a more cleaned up 'production' ready version

This was a fun little project

[CuriosityBug]

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