How to check if objects intersect or if one object is inside another? (VBA) - CorelDRAW Graphics Suite 2019 for Windows - CorelDRAW Graphics Suite 2019 - CorelDRAW Community

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 ###---

'Variables

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) scheck1.ConvertToCurves scheck2.ConvertToCurves

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?

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

Do 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

ExitSub: ActiveDocument.EndCommandGroup Optimization = False ActiveDocument.ClearSelection ActiveWindow.Refresh Exit Sub