#1




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




Re: a shape on top of another
Here is some code you can start from:
Code:
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 
#3




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




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




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




thank you alex,
you´re the greatest, just as always 
#8




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! Last edited by m31uk3; 15012008 at 09:25. 
#9




Another Q.....
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: Last edited by dungbtl; 28022008 at 07:03. 
#10




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

Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)  
Thread Tools  Search this Thread 
Display Modes  


Similar Threads  
Thread  Thread Starter  Forum  Replies  Last Post 
Moving Shape to another page using C++  moodwin  CorelDRAW/Corel DESIGNER VBA  4  18032005 03:01 
Howto uniquely identify a shape in VBA code  jemmyell  CorelDRAW/Corel DESIGNER VBA  9  11022005 22:05 
I think I'm getting better...  Peter Clifton  Code Critique  3  27102004 04:50 
Getting the center X on a text shape  Rick Randall  CorelDRAW/Corel DESIGNER VBA  4  03082004 19:27 
Shape Looping...  Craig Tucker  CorelDRAW/Corel DESIGNER VBA  9  21062004 10:15 