Maybe try this option:
Sub PreventShapeOverlap()
Dim sld As Slide
Dim shp As Shape
Dim shp2 As Shape
Dim overlap As Boolean
Set sld = ActivePresentation.Slides(1)
' Replace with the desired slide index
For Each shp In sld.Shapes overlap = False
For Each shp2 In sld.Shapes
If shp.Name <> shp2.Name Then
' Avoid comparing a shape with itself
' Check for intersection using bounding boxes
If Not Intersect(shp.Left, shp.Top, shp.Left + shp.Width, shp.Top + shp.Height, _
shp2.Left, shp2.Top, shp2.Left + shp2.Width, shp2.Top + shp2.Height) Is Nothing Then
overlap = True
Exit For
' No need to check further if overlap is found
End If
End If
Next shp2
' If overlap detected, adjust the position (example: move right)
If overlap Then
shp.Left = shp.Left + 10
Adjust the offset value as needed
End If
Next shp
End Sub
Function Intersect(x1 As Single, y1 As Single, x2 As Single, y2 As Single, _
x3 As Single, y3 As Single, x4 As Single, y4 As Single) As Variant
' Calculate the intersection points of the lines forming the rectangles
Dim m1 As Double, b1 As Double Dim m2 As Double, b2 As Double Dim x As Double, y As Double
' Handle vertical lines
If x1 = x2 Then
If x3 <= x1 And x4 >= x1 Then
y = Application.WorksheetFunction.Max(y1, y3)
y = Application.WorksheetFunction.Min(y2, y4) Intersect = Array(x1, y) Else Intersect = Nothing
End If
Else
If x3 = x4 Then
If x1 <= x3 And x2 >= x3 Then
y = Application.WorksheetFunction.Max(y1, y3)
y = Application.WorksheetFunction.Min(y2, y4) Intersect = Array(x3, y)
Else
Intersect = Nothing
End If
' Handle horizontal lines
Else
If y1 = y2 Then
If y3 <= y1 And y4 >= y1 Then
x = Application.WorksheetFunction.Max(x1, x3)
x = Application.WorksheetFunction.Min(x2, x4) Intersect = Array(x, y1)
Else
Intersect = Nothing
End If
Else
If y3 = y4 Then
If y1 <= y3 And y2 >= y3 Then
x = Application.WorksheetFunction.Max(x1, x3)
x = Application.WorksheetFunction.Min(x2, x4) Intersect = Array(x, y3)
Else
Intersect = Nothing
End If
' Calculate slopes and intercepts for non-vertical/horizontal lines
Else
m1 = (y2 - y1) / (x2 - x1) b1 = y1 - m1 * x1 m2 = (y4 - y3) / (x4 - x3) b2 = y3 - m2 * x3
' Check for parallel lines If m1 = m2 Then
Intersect = Nothing
Else
x = (b2 - b1) / (m1 - m2) y = m1 * x + b1
' Check if intersection point is within the bounds of both rectangles
If (x >= x1 And x <= x2 And x >= x3 And x <= x4) And_
(y >= y1 And y <= y2 And y >= y3 And y <= y4) Then
Intersect = Array(x, y)
Else
Intersect = Nothing
End If
End If
End If
End Function