Consulting

Results 1 to 2 of 2

Thread: If objects are overlapping, move one object a few "spaces" from the other?

  1. #1
    VBAX Regular
    Joined
    Mar 2019
    Posts
    73
    Location

    Post If objects are overlapping, move one object a few "spaces" from the other?

    I'm looking for some help with code that will:

    * Identify if Picture 2 is overlapping Rectangle 2
    * If it IS, nudge Picture 2 a few "spaces", to put some distance between the two shapes
    * The Picture 2 may need to be nudged to the left OR straight up, depending on whether Rectangle 2 is: A) positioned vertically on the right side of the slide OR
    B) positioned horizontally on the bottom of the slide

    Is this possible? I know object positioning can be a challenge in Powerpoint.

  2. #2
    Moderator VBAX Wizard Aussiebear's Avatar
    Joined
    Dec 2005
    Location
    Queensland
    Posts
    5,293
    Location
    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
    Remember To Do the Following....
    Use [Code].... [/Code] tags when posting code to the thread.
    Mark your thread as Solved if satisfied by using the Thread Tools options.
    If posting the same issue to another forum please show the link

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •