CODEWITHSUNDEEP
vbapowerpoint
Pratik Gujarathi
Pratik Gujarathi

Reputation: 768

How To Find Out If Two Textboxes Or Shapes Overlap Using VBA in PowerPoint 2007?

Is their any way to find out if two textboxes or shapes overlap using VBA in PowerPoint (2007)?

Thanks

Upvotes: 0

Views: 4672

Answers (3)

Kram Kramer
Kram Kramer

Reputation: 123

The codes posted by Steve Rindsberg's are not perfectly correct.

The following codes are better than Steve Rindsberg's codes.

But the following code still is not okey if shape borders are visible like Steve Rindsberg's code.

Public Function ShapesOverlap(aShape As Object, bShape As Object) As Boolean

Dim aLeft As Single
Dim aRight As Single
Dim aTop As Single
Dim aBottom As Single

aLeft = aShape.Left
aRight = aShape.Left + aShape.Width
aTop = aShape.Top
aBottom = aShape.Top + aShape.Height

Dim bLeft As Single
Dim bRight As Single
Dim bTop As Single
Dim bBottom As Single

bLeft = bShape.Left
bRight = bShape.Left + bShape.Width
bTop = bShape.Top
bBottom = bShape.Top + bShape.Height

Dim DoesOverlapExist As Boolean
DoesOverlapExist = False
    
'First type of overlap
If bLeft >= aLeft Then
    If bLeft <= aRight Then
        If bTop >= aTop Then
            If bTop <= aBottom Then
                DoesOverlapExist = True
            End If
        End If
    End If
End If

'Second type of overlap
If bLeft >= aLeft Then
    If bLeft <= aRight Then
        If bBottom >= aTop Then
            If bBottom <= aBottom Then
                DoesOverlapExist = True
            End If
        End If
    End If
End If
    
'Third type of overlap
If bRight >= aLeft Then
    If bRight <= aRight Then
        If bTop >= aTop Then
            If bTop <= aBottom Then
                DoesOverlapExist = True
            End If
        End If
    End If
End If
    
'Fourth type of overlap
If bRight >= aLeft Then
    If bRight <= aRight Then
        If bBottom >= aTop Then
            If bBottom <= aBottom Then
                DoesOverlapExist = True
            End If
        End If
    End If
End If
    
ShapesOverlap = DoesOverlapExist

End Function

The following picture shows 4 types of overlaps.

enter image description here

Upvotes: 1

Steve Rindsberg
Steve Rindsberg

Reputation: 3528

This should get you going.

It still needs to account for boundary cases:

Do two shapes just touching count as an overlap or not?

What about line thickness? The shape size doesn't include the line thickness, but a thick line might cause the shapes to visual overlap.

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

Upvotes: 6

Tony Dallimore
Tony Dallimore

Reputation: 12413

Unless there is some deep significance to the question that I am missing, the answer is yes. Is it that you do not know how to access the dimensions of the shapes or you do know how to use the dimensions to determine if the shapes overlap?

The following macro, outputs the dimensions of each shape on each slide to the Immediate window. With this information it would not be difficult to check for overlaps.

Option Explicit
Sub DsplDimensions()

  Dim InxSlide As Long
  Dim InxShape As Long

  With ActivePresentation
    For InxSlide = 1 To .Slides.Count
      Debug.Print "Slide " & InxSlide
      With .Slides(InxSlide)
        For InxShape = 1 To .Shapes.Count
          With .Shapes(InxShape)
            Debug.Print " Shape " & InxShape
            Debug.Print "  Top & left " & .Top & " " & .Left
            Debug.Print "  Height & width " & .Height & " " & .Width
          End With
        Next
      End With
    Next
  End With

Upvotes: 0

Related Questions