a shape on top of another

hi there,

is it possible to determine, if a shape is on top on another one?

in another words i wanna write a script where all shapes that don´t touch another shape and have white fill will be deleted..

this is for my roland pc60 to work with.

any suggestions?

thanks in advance.

[Alex]

Here is some code you can start from:

Sub RemoveWhiteObjects()
    Dim sr As ShapeRange
    Dim i As Long, j As Long
    Dim s1 As Shape, s2 As Shape
    Dim bOverlap As Boolean
    Dim nDelCount As Long
    
    Set sr = ActivePage.FindShapes()
    
    nDelCount = 0
    For i = 1 To sr.Count - 1
        Set s1 = sr(i)
        If ValidTopObject(s1) Then
            bOverlap = False
            For j = i + 1 To sr.Count
                Set s2 = sr(j)
                If ValidBottomObject(s2) Then
                    If Overlap(s1, s2) Then
                        bOverlap = True
                        Exit For
                    End If
                End If
            Next j
            
            If Not bOverlap Then
                s1.Delete
                nDelCount = nDelCount + 1
            End If
        End If
    Next i
    
    MsgBox nDelCount & " white object(s) deleted", vbInformation
End Sub

'========================================

Private Function ValidCurveObject(ByVal s As Shape) As Boolean
    Select Case s.Type
        Case cdrRectangleShape, cdrPolygonShape, cdrPerfectShape, cdrEllipseShape, cdrCurveShape
            ValidCurveObject = True
        Case Else
            ValidCurveObject = False
    End Select
    
End Function

'========================================

Private Function ValidTopObject(ByVal s As Shape) As Boolean
    Dim bValid As Boolean
    
    bValid = ValidCurveObject(s)
    
    If bValid Then
        bValid = (s.Outline.Type = cdrNoOutline) And (s.Fill.Type = cdrUniformFill)
    End If
    
    If bValid Then
        bValid = s.Fill.UniformColor.IsSame(CreateCMYKColor(0, 0, 0, 0))
    End If
    
    ValidTopObject = bValid
End Function

'========================================

Private Function ValidBottomObject(ByVal s As Shape) As Boolean
    ValidBottomObject = s.Type <> cdrGroupShape
End Function

'========================================

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

'========================================

Private Function Overlap(ByVal s1 As Shape, ByVal s2 As Shape) As Boolean
    Dim x11 As Double, y11 As Double, x12 As Double, y12 As Double
    Dim w1 As Double, h1 As Double
    Dim x21 As Double, y21 As Double, x22 As Double, y22 As Double
    Dim w2 As Double, h2 As Double
    
    ' Get bounding boxes of the two shapes
    s1.GetBoundingBox x11, y11, w1, h1
    s2.GetBoundingBox x21, y21, w2, h2
    
    ' Calculate the bounding rectangle corner coordinates
    x12 = x11 + w1
    y12 = y11 + h1
    x22 = x12 + w2
    y22 = y12 + h2
    
    ' Find the intersection of the two rectangles
    If x11 < x21 Then x11 = x21
    If y11 < y21 Then y11 = y21
    If x12 > x22 Then x12 = x22
    If y12 > y22 Then y12 = y22
    
    ' See if there is intersection between the two bounding rectangles
    If x11 < x12 And y11 < y12 Then
        ' There might be an intersection
        ' Check if the back object is "normal" shape and we can do some more
        ' detailed analysis. If not, then bounding box check is all we can do
        If ValidCurveObject(s2) Then
            Overlap = FindIntersections(s1.DisplayCurve, s2.DisplayCurve)
        Else
            Overlap = True
        End If
    Else
        ' No intersection for sure
        Overlap = False
    End If
End Function

I hope this helps

hey alex,

thank you very very much for your help..

when i try your script, a white object, that lies on top of another (black) shape will be deleted, too.
a white shape which is touching a black shape, still lies on top.

when i have some time, i will try to understand your code so i can try to alter it.

again thank you very much.

[Alex]

Do you have a sample file that shows the problem? It seems to work fine here, but maybe I just do not create objects positioned exactly to reproduce the problem.

unfortunately i´m back at work not before tuesday, so then i can send you the requested file.

here is what i tested..

i placed 3 black rectangles on a sheet.
then i placed on top of the left rect. a white rect. without outline (a little smaller so i can see the outline of the black rect.).
then i placed a white rect. next to the middle rect.
at last i placed a white rect. next to the right black rect., touching this black rect.


know what i mean?

ok so far so good. then i ran the script.

after running the script all the black rect. and the right white rect. (which is touching the right black rect.) were on their place. the left and middle white rect. were deleted.
but i need the right white rect. to remain.

its not all that complicated. i´m not good in english so i don´t know how to describe this better.. sorry for that.

if there are any questions left so write to me.
unfortunately my girlfriend has got a job in another town here in good old germany so i´m here again tuesday at least i think.

´til then.. thank you alex.

[Alex]

Ok, it's my fault. For some reason I thought that if the top (white) and bottom (black) objects do not intersect, they do not overlap. However in your case, if the white (smaller) object lies exactly inside the black (larger) one, there are no intersections of their sides, yet the white still overlaps the black.

I have added one extra check to ensure this is accounted for. The trick is to see if there are no intersections of the sides, it is sufficient to get any point on the top object and see if it is actually inside the bottom one (that is, if the point is in the fill of the shape). It doesn't matter which point we choose. If one is inside, all will be inside, because there are no intersections. I chose to get the position of the first node of the white object to see if it is inside of the bottom object.

I had modified the Overlap function by adding just one extra check:

Overlap = FindIntersections(s1.DisplayCurve, s2.DisplayCurve)
If Not Overlap Then
    s1.DisplayCurve.Nodes(1).GetPosition x, y
    Overlap = (s2.IsOnShape(x, y) <> cdrOutsideShape)
End If

The complete code of that function follows:

Private Function Overlap(ByVal s1 As Shape, ByVal s2 As Shape) As Boolean
    Dim x11 As Double, y11 As Double, x12 As Double, y12 As Double
    Dim w1 As Double, h1 As Double
    Dim x21 As Double, y21 As Double, x22 As Double, y22 As Double
    Dim w2 As Double, h2 As Double
    Dim x As Double, y As Double
    
    ' Get bounding boxes of the two shapes
    s1.GetBoundingBox x11, y11, w1, h1
    s2.GetBoundingBox x21, y21, w2, h2
    
    ' Calculate the bounding rectangle corner coordinates
    x12 = x11 + w1
    y12 = y11 + h1
    x22 = x12 + w2
    y22 = y12 + h2
    
    ' Find the intersection of the two rectangles
    If x11 < x21 Then x11 = x21
    If y11 < y21 Then y11 = y21
    If x12 > x22 Then x12 = x22
    If y12 > y22 Then y12 = y22
    
    ' See if there is intersection between the two bounding rectangles
    If x11 < x12 And y11 < y12 Then
        ' There might be an intersection
        ' Check if the back object is "normal" shape and we can do some more
        ' detailed analysis. If not, then bounding box check is all we can do
        If ValidCurveObject(s2) Then
            Overlap = FindIntersections(s1.DisplayCurve, s2.DisplayCurve)
            If Not Overlap Then
                ' If the objects do not intersect, it might be that the top
                ' object lies completely inside the bottom one
                ' Check to see if the at least one node of the top curve (s1)
                ' is inside the bottom one (s1)
                s1.DisplayCurve.Nodes(1).GetPosition x, y
                Overlap = (s2.IsOnShape(x, y) <> cdrOutsideShape)
            End If
        Else
            Overlap = True
        End If
    Else
        ' No intersection for sure
        Overlap = False
    End If
End Function

thank you alex,

you´re the greatest, just as always

This code looks promising...however since its from 2004 are there any simple improvements that could be made to it running on CorelDraw X3?

What about something a tad lighter? Something that just did a bounding box check?

I would be happy to do ground work if someone has some good points to get me started.

Thanks!

Hmmm.... i didnt see this one till today.

I did a search on the Intersect but none of it was what I needed. I tried a few example codes but screwed it all up.
I have no clue how this stuff works.

My question and I know it's possible.

If i place an object over a series/group of objects can that Intersect command select whats over/under it? Including the objects within that dont intersect or sould I make an Inside contour a couple times?

I need to select the objects that intersect, seems a bit easier than selecting them individually. Yes, i know marquee select. Marquee select is square and grabs extra trouble withit, meaning I have to delete the excess.... not good.




See attached pic:

w0xx0m... you have any funky new code for something like the above?