如何在PowerPoint 2007中使用VBA查找两个文本框或形状是否重叠？

Question

这应该让你前进。

Answer 1

有两个形状只是碰到一个重叠吗？

线厚度如何？形状尺寸不包括线厚度，但是厚线可能会导致形状视觉重叠。

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

除非我缺少这个问题，否则答案是肯定的。 您是否不知道如何访问形状的尺寸，或者您知道如何使用尺寸来确定形状是否重叠？

以下宏，将每个幻灯片上每个形状的尺寸输出到直接的窗口。    有了这些信息，很难检查重叠。

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

Answer 2

以下代码更好。

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