Hello!
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 ###---
'Variables
Dim srcheck As ShapeRange 'Active SelectionDim scheck1 As Shape ' First rectangleDim scheck2 As Shape 'Second rectangleDim i As Integer 'CounterDim j As Integer 'CounterDim n As Integer 'Counter
n = 1 'Set value of n as 1Set 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?
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
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
ErrHandler: Resume ExitSubEnd Sub
I`ll try it tomorrow, thanks!