How to detect holes in combined curve objects?

[Plixo]

Hi,

Found some time to go back to this topic since quite useful on our daily work doing quite complex laser cutting at Plixo.

Managed to implement a solution [see code extract below] that seems to work in all cases and in a efficient manner [processed thousands of curves in less than 10s].


Picture of small example of set of curves with the dialog for settings the params of the procedure:


And the result with the option of ordering and coloring the curves based on their depth:


Extract of the source [since it's now integrated in a full set of tools with forms, link to the laser etc, litle bit difficult to extract it, but if you are interested, let me know and I will try to make a standalone as soon as I get free time]:


' Copyright Plixo 2011, All rights reserved

Option Explicit

Private Function PRColorAndOrderInsideCurves(ByRef rangeToParse As ShapeRange, ByVal inDepth As Boolean, ByVal ordering As plxoOrdering, ByVal coloring As plxoColoring, ByRef colorPalette As Palette, ByVal outlineColorIndex As Integer, ByVal fillColorIndex As Integer) As ShapeRange

Dim s As Shape
Dim ss As Shape
Dim si As Shape
Dim sBreak As ShapeRange

Dim sCurves As New ShapeRange
Dim sGroups As New ShapeRange
Dim inside As Shape
Dim outside As Shape
'Dim results As New ShapeRange

Dim i As Integer
Dim j As Integer
Dim count As Integer

Dim depth() As Integer
Dim maxdepth As Integer

' Parse all shapes, put them as curves and break them
' Keep groups as groups for 1st pass then do algo recursively for each group.
For Each s In rangeToParse
Select Case s.Type
Case cdrGroupShape
' Do groups in a second pass
sGroups.Add s
'sCurves.Add s
GoTo NextShape
Case cdrCurveShape
Case cdrRectangleShape, cdrEllipseShape
s.ConvertToCurves
Case cdrTextShape
s.ConvertToCurves
Case Else
' Should raise an error and display error message here
End Select

If inDepth Then
Else
If coloring Then ColorShape s, coloring, colorPalette, outlineColorIndex, fillColorIndex
End If

If s.Curve.SubPaths.count > 1 Then
Set si = s.BreakApartEx.Group
sGroups.Add si
Else
sCurves.Add s
End If

NextShape:
Next s

' Sort all shapes by increasing area
If sCurves.count > 1 Then QSortShapesByArea sCurves

' Parse all curves and find which one are insides
count = sCurves.count

If inDepth Then ReDim depth(count)

For i = 1 To count
Set ss = sCurves(i)

For j = i + 1 To count

Set s = sCurves(j)

If ShapeInsideShape(ss, s, False) Then
If inDepth Then
depth(i) = depth(i) + 1
Select Case ordering
Case plxoOrderingToFront
s.OrderToBack
Case plxoOrderingToBack
s.OrderToFront
End Select
Else
If coloring > 0 Then ColorShape ss, coloring, colorPalette, outlineColorIndex + 1, fillColorIndex + 1
Select Case ordering
Case plxoOrderingToFront
ss.OrderFrontOf s
Case plxoOrderingToBack
ss.OrderBackOf s
End Select
GoTo Next_i
End If

Else

End If


Next_j:
Next j
Next_i:
Next i

If inDepth And coloring > 0 Then
For i = 1 To count
ColorShape sCurves(i), coloring, colorPalette, outlineColorIndex + depth(i), fillColorIndex + depth(i)
Next i
End If

' Now apply same for each groups if any
'If inDepth Then colorIndex = colorIndex + 1

For Each s In sGroups
Set sBreak = s.UngroupEx
Set sBreak = PRColorAndOrderInsideCurves(sBreak, inDepth, ordering, coloring, colorPalette, outlineColorIndex, fillColorIndex)
Set s = sBreak.Group
sCurves.Add s
Next s

Set PRColorAndOrderInsideCurves = sCurves
End Function

Public Function ColorAndOrderInsideCurves(rangeToParse As ShapeRange, Optional ByVal inDepth As Boolean = True, Optional ByVal ordering As plxoOrdering = plxoOrderingToFront, Optional ByVal coloring As plxoColoring = plxoColoringOutline, Optional ByRef colorPalette As Palette = Nothing, Optional ByVal outlineColorIndex As Integer = 1, Optional ByVal fillColorIndex As Integer = 1) As ShapeRange

' Call subs that do the work recursilely
' This stub is here in case need to to something at beg and end of process

Set ColorAndOrderInsideCurves = PRColorAndOrderInsideCurves(rangeToParse, inDepth, ordering, coloring, colorPalette, outlineColorIndex, fillColorIndex)

End Function


Private Sub PRQSortShapesByArea(ByRef sr() As Shape, ByVal Lb As Long, ByVal Ub As Long)
Dim lbStack(32) As Long
Dim ubStack(32) As Long
Dim sp As Long ' stack pointer
Dim lbx As Long ' current lower-bound
Dim ubx As Long ' current upper-bound
Dim m As Long
Dim p As Long ' index to pivot
Dim i As Long
Dim j As Long
Dim s As Shape ' temp used for exchanges

lbStack(0) = Lb
ubStack(0) = Ub
sp = 0
Do While sp >= 0
lbx = lbStack(sp)
ubx = ubStack(sp)

Do While (lbx < ubx)

' select pivot and exchange with 1st element
p = lbx + (ubx - lbx) \ 2

' exchange lbx, p
Set s = sr(lbx)
Set sr(lbx) = sr(p)
Set sr(p) = s

' partition into two segments
i = lbx + 1
j = ubx
Do
Do While i < j
If sr(lbx).Curve.Area <= sr(i).Curve.Area Then Exit Do
i = i + 1
Loop

Do While j >= i
If sr(j).Curve.Area <= sr(lbx).Curve.Area Then Exit Do
j = j - 1
Loop

If i >= j Then Exit Do

' exchange i, j
Set s = sr(i)
Set sr(i) = sr(j)
Set sr(j) = s

j = j - 1
i = i + 1
Loop

' pivot belongs in A[j]
' exchange lbx, j
Set s = sr(lbx)
Set sr(lbx) = sr(j)
Set sr(j) = s

m = j

' keep processing smallest segment, and stack largest
If m - lbx <= ubx - m Then
If m + 1 < ubx Then
lbStack(sp) = m + 1
ubStack(sp) = ubx
sp = sp + 1
End If
ubx = m - 1
Else
If m - 1 > lbx Then
lbStack(sp) = lbx
ubStack(sp) = m - 1
sp = sp + 1
End If
lbx = m + 1
End If
Loop
sp = sp - 1
Loop
End Sub


Public Sub QSortShapesByArea(ByRef sr As ShapeRange)

' 1st create array of each shapes to sort in place
'Static rsr(32767) As Shape
Dim rsr() As Shape
Dim i As Integer
Dim count As Integer
Dim s As Shape

count = sr.count
ReDim rsr(1 To count)
i = 1

For Each s In sr
Set rsr(i) = sr(i)
i = i + 1
Next s

' Now sort array
PRQSortShapesByArea rsr, 1, count

' Now recreate sr
sr.RemoveAll

For i = 1 To count
sr.Add rsr(i)
Next i

End Sub


Public Function ShapeInsideShape(ByRef s1 As Shape, ByRef s2 As Shape, Optional ByVal exact As Boolean = False) As Boolean
Dim c1 As Curve
Dim c2 As Curve
Dim n1 As Node
Dim sp1 As SubPath
Dim sp2 As SubPath

ShapeInsideShape = False

' First check bounding rect inside each other
If s1.LeftX > s2.RightX Then Exit Function
If s1.LeftX < s2.LeftX Then Exit Function
If s1.RightX < s2.LeftX Then Exit Function
If s1.RightX > s2.RightX Then Exit Function
If s1.BottomY > s2.TopY Then Exit Function
If s1.BottomY < s2.BottomY Then Exit Function
If s1.TopY < s2.BottomY Then Exit Function
If s1.TopY > s2.TopY Then Exit Function

' Then check all points of s1 curve inside s2
Set c1 = s1.Curve
Set c2 = s2.Curve

For Each n1 In c1.Nodes
If Not c2.IsPointInside(n1.PositionX, n1.PositionY) Then Exit Function
Next n1

If exact Then
For Each sp1 In c1.SubPaths
For Each sp2 In c2.SubPaths
If sp1.GetIntersections(sp2).count > 0 Then Exit Function
Next sp2
Next sp1
End If

ShapeInsideShape = True
End Function


Alexis Martial, Greek Daemon Optimizer ;-)
http://www.facebook.com/#!/BlueFoxSgp

[buga]

Ohhh that macro is great.

Would you mind sharing? with only the code, without the forms, I can not make working demo.

Please. I would be very grateful

a greeting

[Plixo]

Dear Buga and forum members,

I quickly isolated the InsideHoles form and code.

Find here links to FindHoles.gms [too big to upload to the forum] and a simple coreldraw file used for test FindHolesTest.

Alternatively, I put a rough dedicated software page on our website for you to download them

Tried it very quickly with X5 and seems OK.

More focusing on full test in my full application, but would be glad to look at any issue you get with it.

Alexis Martial
Managing Director and Hole Finder of Plixo: the Best Laser Cutting company in Singapore

[buga]

thank you so much

a greeting

[Plixo]

Good to see people appreciating and sharing, that's the value of this forum.

Will probably end-up having a full application avail commercially but will continue to release more generic modules of it free of charge here.

Alexis Martial
Optimizer to Hell
Plixo, a Unique Boutique Workshop in Singapore:
Laser cutting and Engraving
Large format Printing
and much more...

Originally Posted by Plixo

Good to see people appreciating and sharing, that's the value of this forum.

Will probably end-up having a full application avail commercially but will continue to release more generic modules of it free of charge here.

Alexis Martial
Optimizer to Hell
Plixo, a Unique Boutique Workshop in Singapore:
Laser cutting and Engraving
Large format Printing
and much more...

Hi , I found a problem with the macro. For example if you use an outline font and you use the Russian doll option and the word has a letter "R" at the beginning the R letter is broken apart and it colors it all in black and the rest its processed as it should. Is there a work around for this?

Later on I tried to write a different word "ROBOTA" and the R and B letter is not processed correctly.

Second try I wrote the alphabet in a text line "ABCDEFGHIJKLMNOPQRSTUVWXYZ" one with normal font and one with outline font.

The result is like this the normal text is processed and only some letters are full black however the outline version is not processed at all. I tried over and over again and nothing happens just it converts it to curves.

[Plixo]

Hi David and forums members,

Yes, my previous VBA macro for Corel to detect hole was quite buggy, slow and limited.

Find attached a totally rewritten one, with many options, a form to choose options, including:
- recursive
- choose to either color or order [useful for laser/CNC] or both the shapes
- etc

I include screen dumps of simple examples but I tested it on huge texts and up to 10 levels of imbricated curves, an d we use it on a daily basis now in our laser cutting division so should be OK ;-)

Please feel free to distribute but as is i.e. no modifications except bug fixes of course

Alexis Martial
Optimizer to Hell & occasionally Managing Director of
Plixo, a Unique Boutique Workshop in Singapore:
signboards
Large format Printing
Laser cutting and Engraving
mirror acrylic
and much more...

[ekaterina]

Hi, I also made a try, s. the code below. It is much simpler, for it only cuts all in-shapes out of their containers after they have been broken apart. Odd in-shapes (or Russian dolls, or Matreshkas) are not filled. Thus smaller parts get visible against their background. The Fill Color is always the original color of the container. I tested it with forms on fonts (up to depth 3), so far it works.

Option Base 1
Option Explicit

Sub Holess()
Dim s As Shape, s1 As Shape, minus As Shape
Dim n As Node
Dim i As Long, iE As Long, i1 As Long, i2 As Long, iNode As Long, iIsIn As Integer, iID As Long
Dim Arr(), IsInShapesID(), ArrShapes()
Dim ifIsIn As Boolean
Dim brk As ShapeRange
Dim x As Double, y As Double


'--------------------------------------------
iE = ActiveLayer.Shapes.Count
ReDim ArrShapes(iE) 'the order of shapes will be changed after the break, so I better handle them as a fixed array
For i = 1 To iE
    Set ArrShapes(i) = ActiveLayer.Shapes(i)
Next i

For i = 1 To iE
    Set s = ArrShapes(i)
    If s.Type <> 3 Then s.ConvertToCurves
    Set brk = s.BreakApartEx
Next i
'----------------------------------------------
iE = ActiveLayer.Shapes.Count
ReDim IsInShapes(iE)
ReDim IsInShapesID(iE)

For i = 1 To iE
    IsInShapes(i) = Array()
    IsInShapesID(i) = Array()
    ActiveLayer.Shapes(i).Name = i
Next i

For i = 1 To iE - 1' here I remember all the containers' names for all the shapes as an array of arrays
    Set s = ActiveLayer.Shapes(i)
    For i1 = i + 1 To iE
        Set s1 = ActiveLayer.Shapes(i1)
        ifIsIn = True
        i2 = s1.Curve.Nodes.Count
        For iNode = 1 To i2
            Set n = s1.Curve.Nodes(iNode)
            n.GetPosition x, y
            If s.IsOnShape(x, y) < 1 Then
                ifIsIn = False
                iNode = i2 + 1
            End If
        Next iNode
        
        If ifIsIn = True Then
            iIsIn = UBound(IsInShapesID(i1)) + 1
            
            Arr = IsInShapesID(i1)'the array of the names of the containers
            ReDim Preserve Arr(iIsIn)
            Arr(iIsIn) = i
            IsInShapesID(i1) = Arr
        End If
    Next i1
Next i

For i = 1 To iE
    iIsIn = UBound(IsInShapesID(i))
    
    If iIsIn > 0 Then
        Set s = ActiveLayer.Shapes.FindShapes(i)(1)
        
        If CInt(iIsIn / 2) <> iIsIn / 2 Then
            s.Fill.ApplyNoFill
        End If
        
        For i1 = 1 To iIsIn
            iID = IsInShapesID(i)(i1)
            Set s1 = ActiveLayer.Shapes.FindShapes(iID)(1)
            If s1 Is Nothing Then
            Else
                Set minus = s.Trim(s1, True, True)
                s1.Delete
            End If
        Next i1
        
    End If
Next i

End Sub