Hi, all!
I have been working on a project that sounded fairly simple on paper, but for whatever reason is proving to be quite challenging... well, mostly to CorelDRAW being unpredictable in the way it acts when it should act the same every time.
The gist of the project is this - select similar shapes based on an approximation of their geometry. Let’s say we have a shape:
We divide it into sectors, like this:
And give each sector a unique tag, in my case 2^n, then sum them together, so basically we can get a “hash”, I guess, of the shape.
To make things easier I decided to use CorelDRAW’s IsOnShape function and thus our output looks like this:
So far, so good. Problems arise when we have more shapes, which I know are exactly the same, but CorelDRAW decides that on one of them the given point is on the shape, but for other shapes it isn’t, like this:
The base shape is exactly the same - as you can see for some reason on the right side one of the points triggers as overlapping the shape, but on another shape it doesn’t.
I’m seeing three possibilities:
1) Something is wrong in my code that makes the point position/size shift (not the case as far as I can tell)
2) CorelDRAW is fairly rough with the IsOnShape function and does some sort of an approximation on the inside.
3) There is a bug in the IsOnShape function.
Hopefully you won’t be turned off by the seemingly complex code and we can find a solution, it’s a fairly useful function.
Sub SelectSimilar()
If CheckDoc(1) Then
'boostStart "Index"
Dim S As Shape
Dim T As Shape
Dim SR As New ShapeRange
Dim TR As ShapeRange
Dim A As Long
Dim OurShape As Currency
Set T = ActiveSelectionRange.Shapes.First
SR.Add T
Set TR = ActivePage.Shapes.All
OurShape = SimilarityRating(T)
ReDim Catalogue(TR.Count + 1, 2) As Currency
For A = 1 To TR.Count
Set S = TR(A)
Catalogue(A, 1) = SimilarityRating(S)
Catalogue(A, 2) = S.StaticID
Debug.Print Catalogue(A, 1)
Next A
If Catalogue(A, 1) = OurShape Then
Set S = ActivePage.FindShape(, , Catalogue(A, 2))
If S.SizeHeight > T.SizeHeight * 0.5 And S.SizeHeight < T.SizeHeight * 1.5 And T.SizeWidth > S.SizeWidth * 0.5 And T.SizeWidth < S.SizeWidth * 1.5 Then
SR.Add S
End If
SR.CreateSelection
'boostFinish True
End Sub
Function SimilarityRating(S As Shape) As Currency
Dim X As Double
Dim Y As Double
Dim Size As Double
Dim Steps As Double
Dim Gap As Double
Steps = 6
Dim Index As Currency
Dim A As Byte
Index = 0
A = 0
If S.SizeHeight > S.SizeWidth Then
Size = S.SizeHeight
Else
Size = S.SizeWidth
Gap = Size / Steps
Size = Size - Gap
For Y = 0 To Steps
For X = 0 To Steps
If S.IsOnShape((S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap * 0.5) Then
'Debug, can comment out
ActiveLayer.CreateEllipse2 (S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap * 0.5
Index = Index + 2 ^ A
ActiveLayer.CreateEllipse2 (S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap / 8
A = A + 1
Next X
Next Y
ActiveLayer.CreateArtisticText S.LeftX, S.BottomY - 1, Index, , , , 32
SimilarityRating = Index
End Function
Some cool ideas there...
I've noticed the same thing with .isonshape using display shapes seems to help a little but its still not perfect. It seems to work for a few checks then starts to fail when used in quick succession. So I haven't implemented it anywhere in our code base.
The two work around I've used is to use the intersect functionality and do a three stage test (area, curves then centre position test), would be ideal if and a lot faster if isonshape worked all the time but i've used both these methods you might find some worth in there.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75
Option Explicit Sub Inside2() Dim MasterS As Shape, InsideS As Shape Set MasterS = ActiveLayer.CreateEllipse2(0, 0, 200, 200) MasterS.ConvertToCurves Set InsideS = ActiveLayer.CreateEllipse2(50, 0, 100, 100) InsideS.ConvertToCurves If OverLapFunc(MasterS, InsideS) = True Then MsgBox "Inside!" Else MsgBox "Outside!" End If End Sub Function OverLapFunc(ByRef MasterS As Shape, InsideS As Shape) As Boolean OverLapFunc = False 'Quick Area Test If InsideS.LeftX > MasterS.LeftX And InsideS.RightX < MasterS.RightX _ And InsideS.TopY < MasterS.TopY And InsideS.BottomY > MasterS.BottomY Then 'If curves intersect then there must be an overlap If MasterS.DisplayCurve.IntersectsWith(InsideS.DisplayCurve) Then OverLapFunc = True Else 'If it doesn't intersect the outcurve and its within its area the shape must be fully inside If MasterS.DisplayCurve.IsPointInside(InsideS.CenterX, InsideS.CenterY) = True Then OverLapFunc = True End If End If End If End Function Sub Inside() Dim MasterS As Shape, InsideS As Shape Set MasterS = ActiveLayer.CreateEllipse2(0, 0, 200, 200) MasterS.ConvertToCurves Set InsideS = ActiveLayer.CreateEllipse2(100, 0, 100, 100) InsideS.ConvertToCurves If InSideTest(MasterS, InsideS) = True Then MsgBox "Inside!" Else MsgBox "Outside!" End If End Sub Private Function InSideTest(ByRef MasterS As Shape, InsideS As Shape) As Boolean Dim RemainderS As Shape On Error GoTo Failed Set RemainderS = MasterS.Intersect(InsideS, True, True) If Not RemainderS Is Nothing Then InSideTest = True RemainderS.Delete Else InSideTest = False End If Set RemainderS = Nothing Exit Function Failed: InSideTest = False End Function