How to check if objects intersect or if one object is inside another? (VBA)


Imagine the situation.

I drew 20 rectangles. I accidentally copied one rectangle and pasted it in the same place. Since the coordinates of the main rectangle and the copied one are the same, if you look closely, I will see only a slight thickening of the outline, which is almost imperceptible at a quick glance.

And here is the task that I want to implement. I need to ensure that there are no doubles of rectangles and that they do not overlap

The user selects all the rectangles, runs a macro that checks if the rectangles intersect, or if one is on top of the other, and if this situation is detected, one of the two found rectangles is highlighted in red and shifts upwards, for example, 5 centimeters.

I implemented this

---### VBA CODE ###---


Dim srcheck As ShapeRange                    'Active Selection
Dim scheck1 As Shape                             ' First rectangle
Dim scheck2 As Shape                             'Second rectangle
Dim i As Integer                                         'Counter
Dim j As Integer                                         'Counter
Dim n As Integer                                        'Counter

n = 1                                                         'Set value of n as 1
Set srcheck = ActiveSelectionRange      'Set active selection

'Since we need to select two different rectangles, i will be for one rectangle, j for another

For i = n To srcheck.Shapes.count        'Count from the start rectangle in the selection to the end
     For j = n To srcheck.Shapes.count              'Count from the start rectangle in the selection to the end

          If i <> j Then          'If it turns out that the two compared objects are the same rectangle, then go to the next pair

               Set scheck1 = srcheck(i)
               Set scheck2 = srcheck(j)

               If scheck1.Curve.IntersectsWith(scheck2.Curve) = True Then    'If we get intersection then...
                    srcheck(i).Fill.UniformColor.RGBAssign 255, 0, 0                 'fill red and 
                    srcheck(i).Move 2, 2                                                                 'move
               End If

          End If
     Next j
n = n + 1 ' Add one. Now, new cycles will begin already with a deuce, thereby we will not re-check the pairs of rectangles that we have already checked. If this is not done, then checking the first and second rectangle, the next time the second and first will be checked (which is the same)
Next i

As a result, it all works, although I have only done the intersection check so far, the problem is that the same 20 rectangles will be checked sooooo long (190 checks, and can take up to several minutes in time) What can I say when projects can occur from 100 to 10,000 rectangles.

Is it possible, for example, to select a rectangle, somehow understand which rectangles lie closest to it, and already check between them, and not with the entire set of rectangles?

  • I use this. Perhaps you can build from it.

    Sub MarkIntersects()
    Dim s As Shape, sFirst As Shape, sFound As Shape
    Dim srSelection As ShapeRange, srEllipses As New ShapeRange
    Dim x As Double, y As Double, w As Double, h As Double
    Dim spFirst As SubPath, spDisplayCurve As SubPath
    Dim cps As CrossPoints
    Dim cp As CrossPoint

    Set srSelection = ActiveSelectionRange
    srSelection.RemoveRange srSelection.FindAnyOfType(cdrGroupShape, cdrBitmapShape, cdrTextShape)

    ActiveDocument.BeginCommandGroup "Mark Intersects"
    On Error GoTo ErrHandler
    Optimization = True

    Set sFirst = srSelection.FirstShape
    sFirst.GetBoundingBox x, y, w, h
    Set sFound = ActivePage.SelectShapesFromRectangle(x, y, x + w, y + h, True)

    If sFound.Shapes.FindShapes.Count > 1 Then
    For Each s In sFound.Shapes.FindShapes()
    If Not s Is srSelection.FirstShape And srSelection.IndexOf(s) <> 0 Then
    If s.DisplayCurve.IntersectsWith(sFirst.DisplayCurve) Then
    For Each spDisplayCurve In s.DisplayCurve.SubPaths
    For Each spFirst In sFirst.DisplayCurve.SubPaths
    Set cps = spFirst.GetIntersections(spDisplayCurve, cdrAbsoluteSegmentOffset)
    For Each cp In cps
    srEllipses.Add ActiveVirtualLayer.CreateEllipse2(cp.PositionX, cp.PositionY, 0.125)
    Next cp
    Next spFirst
    Next spDisplayCurve
    End If
    End If
    Next s
    End If

    srSelection.Remove 1
    Loop Until srSelection.Shapes.Count = 0

    srEllipses.ApplyUniformFill CreateRGBColor(255, 255, 0)
    If srEllipses.Count > 0 Then ActiveDocument.LogCreateShapeRange srEllipses

    Optimization = False
    Exit Sub

    Resume ExitSub
    End Sub