IsOnShape precision question. Function to select similar shapes.

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

 

        For A = 1 To TR.Count

 

            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

 

            End If

 

        Next A

 

        SR.CreateSelection

 

        'boostFinish True

 

    End If

 

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

    End If

 

    Gap = Size / Steps

    Size = Size - Gap

    Gap = Size / Steps

 

    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

            Else

                'Debug, can comment out

                ActiveLayer.CreateEllipse2 (S.CenterX - Size / 2) + X * Gap, (S.CenterY - Size / 2) + Y * Gap, Gap / 8

            End If

 

            A = A + 1

 

        Next X

 

    Next Y

    

    'Debug, can comment out

    ActiveLayer.CreateArtisticText S.LeftX, S.BottomY - 1, Index, , , , 32

    SimilarityRating = Index

 

End Function

Parents
No Data
Reply
  • 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
    
Children
No Data