#11




Finally a working and efficient solution to detect holes
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 lowerbound Dim ubx As Long ' current upperbound 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 
#12




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 
#13




Macro for hole as separate gms
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 
#14




thank you so much
a greeting 
#15




You're welcome
Good to see people appreciating and sharing, that's the value of this forum.
Will probably endup 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... 
#16




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




Update
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. 
#18




Improved and rewritten GMS to detect holes
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... Last edited by Plixo; 13042012 at 10:30. Reason: formatting mistake 
#19




Hi, I also made a try, s. the code below. It is much simpler, for it only cuts all inshapes out of their containers after they have been broken apart. Odd inshapes (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.
Code:
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 Last edited by ekaterina; 14052012 at 23:12. 
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 
How to detect textbox's language or charset?  litthe  CorelDRAW/Corel DESIGNER VBA  1  24032009 19:52 
Fitting objects to curve  CWCN  CorelDRAW/Corel DESIGNER VBA  1  17112008 12:19 
cannot close combined shape  jemmyell  CorelDRAW/Corel DESIGNER VBA  5  27072005 14:25 
Arrange objects along a curve  Alex  FAQ  1  24052005 10:42 
Detect if VBA is installed (an answer and a question)  reanan  CorelDRAW/Corel DESIGNER VBA  3  04122002 14:35 