Testing whether objects overlap each other

Hi,

I have a script that, given a certain shape, cuts the shapes that are outside it. (similar to Select inverse + Delete in Photoshop, only that it applies to all layers).
This is my code so far:

Sub cut_shape()
Dim matrita As Shape, sh As Shape, fin As Shape
Set matrita = ActivePage.Layers("Layer 1").Shapes(1)
For Each sh In ActivePage.Shapes
    sh.Layer.Activate
    ActiveDocument.ReferencePoint = cdrBottomLeft
    If matrita.IsOnShape(sh.PositionX, sh.PositionY) = cdrOutsideShape Then
        ActiveDocument.ReferencePoint = cdrBottomRight
        If matrita.IsOnShape(sh.PositionX, sh.PositionY) = cdrOutsideShape Then
            ActiveDocument.ReferencePoint = cdrTopLeft
            If matrita.IsOnShape(sh.PositionX, sh.PositionY) = cdrOutsideShape Then
                ActiveDocument.ReferencePoint = cdrTopRight
                If matrita.IsOnShape(sh.PositionX, sh.PositionY) = cdrOutsideShape Then
                    sh.Delete
                ElseIf sh.Type = cdrCurveShape Then
                    Set fin = matrita.Intersect(sh, True, False)
                End If
            ElseIf sh.Type = cdrCurveShape Then
                Set fin = matrita.Intersect(sh, True, False)
            End If
        ElseIf sh.Type = cdrCurveShape Then
            Set fin = matrita.Intersect(sh, True, False)
        End If
    ElseIf sh.Type = cdrCurveShape Then
        Set fin = matrita.Intersect(sh, True, False)
    End If
Next sh
End Sub

So basically I'm testing if of the corners of the bounding box is inside the control shape. If at least one is inside the control shape I intersect them, if not I delete the shape being tested.
The problem is if the shapes are like in the attached picture (in red is the control shape):
- The blue shape, allthough it overlapses the control shape gets deleted (all the corners of the bounding box are outside)
- The green shape gets intersected (and of course produces an ugly Nothing was changed.... error that the On Error directive doesn't catch) because the center and one of the corners of the bounding box are inside the control curve.

Anyone has a better idea on how to test whether two objects overlap?

Thanks.

Another try:

Function is_overlap(mat As Shape, sh As Shape)
Dim n As Node
For Each n In sh.Curve.Nodes.All
    If mat.IsOnShape(n.PositionX, n.PositionY) = cdrInsideShape Then
        is_overlap = 1
        Exit Function
    End If
Next n
is_overlap = 0
End Function

Sub cut_shape()
Dim matrita As Shape, sh As Shape, fin As Shape
Set matrita = ActivePage.Layers("Layer 1").Shapes(1)
For Each sh In ActivePage.Shapes
    sh.Layer.Activate
    If is_overlap(matrita, sh) = 1 Then
        Set fin = matrita.Intersect(sh, True, False)
    Else
        sh.Delete
    End If
Next sh
End Sub

But it works only for curves (not text), it's slow and there is at least one situation when it doesn't work: the blue curve has both nodes outside the control curve, but has a common part.
Other sugestions?

Hi,

I try to implement a function that recognizes if two objects are overlaping or not.

My first idea was to count the objects StartCount, use the interselect function that it is embedded into Corel,
then count the objects again FinalCount and compare theese.
If FinalCount > StartCount then the two objects are overlaped. In the end I have to find and delete the newly created object.

Then I tried dcsquare's Function "is_overlap" and not the cut_shape sub.
I got the classic message..
"user-defined type, not defined" on the "n As New node"
Which declaration do I need?
I use corel Draw 9.0 and my project should complete into this version except if it is impossible to do so
Thanks.

[shelbym]

I hope I understand what you are asking....but keep it simple you just want to crop all the shapes to your selection....

Give this a try and let me know if I missed the mark. It will convert any text to curves (I am sure we could change that if it is a must)

Sub quickCrop() 'Version 1.1
    Dim sSelection As Shape, s As Shape, sel As Shape, sIntersect As Shape
    Dim srOutside As ShapeRange, srInside As New ShapeRange
    Dim x As Double, y As Double, w As Double, h As Double
    
    'Test to make sure only one shape is selected
    If ActiveSelection.Shapes.Count = 0 Then
        MsgBox "Please select an object.", vbOKOnly, "quickCrop"
        Exit Sub
    ElseIf ActiveSelection.Shapes.Count > 1 Then
        MsgBox "Please select only one object.", vbOKOnly, "quickCrop"
        Exit Sub
    ElseIf ActiveSelection.Shapes.Count = 1 Then
        Set sSelection = ActiveShape 'Get the Current Shape
    End If
    
    Optimization = True
    ActiveDocument.BeginCommandGroup "quickCrop"
    On Error GoTo ErrHandler
    
        
    ActiveDocument.ReferencePoint = cdrBottomLeft 'Set our point of reference
    sSelection.GetBoundingBox x, y, w, h 'Get the boundingbox size and position

    Set sel = ActivePage.SelectShapesFromRectangle(x, y, x + w, x + h, True) 'Select all the shapes inside this area, or the touch this area

    For Each s In sel.Shapes
        Set sIntersect = sSelection.Intersect(s, True, False)  'Intersect each shape with the orginal selected shape
        If Not sIntersect Is Nothing Then 'Check for nothing returned
            srInside.Add sIntersect
        End If
    Next s
    
    'Check for Duplicate Shapes (could be improved to be a bit smarter :-))
    For Each s In srInside
        If s.SizeWidth = sSelection.SizeWidth And s.SizeHeight = sSelection.SizeHeight Then s.Delete
    Next s
    
    srInside.Add sSelection 'Add our original selection
    
    Set srOutside = ActivePage.Shapes.All 'All shapes on the page
    srOutside.RemoveRange srInside 'Remove inside shapes
    srOutside.Delete 'Delete all outside shapes
    srInside.CreateSelection 'Select the shapes
    
ExitSub:
    ActiveDocument.EndCommandGroup
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
    Exit Sub

ErrHandler:
    MsgBox "Error occured: " & Err.Description, , , "quickCrop"
    Resume ExitSub
End Sub

-Shelby

First of all thanks for your instant response!

I am sure that I couldn't explained my issue as well.
Your posted code has nothing to do with what I try to do.
Even though your code returned me the same error message "user-defined type, not defined" on the "ShapeRange" ...maybe because I use version 9.0


Anyway...
I need a simple function (not a sub) that gets 2 shapes and gives True or False.
Something like that...

Private Function CheckForOverlaps(sh1 as shape, sh2 as shape)as Boolean
        If sh1 overlaps sh2 then CheckForOverlaps = True
        Else CheckForOverlaps = False
End Function

I need help for the ==> "overlaps"!

Please, take a look at my attachment.
It is a cdr file (ver 9.0) in which I explain what I mean by "overlap".

Thank you in advance.

[shelbym]

I was actually answering the first post. If you want to just text if two shape overlap you can make a function like this. (I do not know if this will work in CorelDRAW 9, I have only tested in X4)

Sub TestFindIntersections()
    Dim sr As ShapeRange
    
    Set sr = ActiveSelectionRange
    
    MsgBox FindIntersections(sr(1).DisplayCurve, sr(2).DisplayCurve)
End Sub

Private Function FindIntersections(ByVal crv1 As Curve, crv2 As Curve) As Boolean
    Dim sp1 As SubPath
    Dim sp2 As SubPath
    Dim bFound As Boolean
    
    bFound = False
    For Each sp1 In crv1.SubPaths
        For Each sp2 In crv2.SubPaths
            If sp1.GetIntersections(sp2).Count > 0 Then
                bFound = True
                Exit For
            End If
        Next sp2
        If bFound Then Exit For
    Next sp1
    
    FindIntersections = bFound
End Function

I have kept the code very simple, just select to shapes and it will return either true or false, there is no error checking.

PS even in X4 there is no "overlaps" sub or function....that is why you need to create your own

-Shelby

It seems that this code does my work!
Once again I tested on corel ver 9.0 and the same message appeared.
Mayebe I should find some general declarations..

I 'll test it tomorrow on X4.. and ll post my results.
I am almost sure that it will play fine!

Anyway, I have to thank you a lot for your help.

I can help on VB code at any time.

X4 has the new Curve.IntersectsWith (Curve) method.
It does not calculate number of intersections, it just report the fact of intersecting. So it should work faster.

if s1.displaycurve.IntersectsWith(s2.displaycurve) then ...

[shelbym]

You rock Lev.....I had missed that!

-Shelby

Thanks a lot guys,

Shelby's code worked nice!

Lev, your interpose was realy important because every shape in my project will have 1000 or much more nodes, because the shapes are exported by another graphic application and the curve translation, gives much more nodes..
Then the combinations between shapes' nodes will be infinite!

You rescued my trial! Thanks a lot again.