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