Subpaths, Segments, and Nodes

Hello All

I have been working with the elements above for a while now and I keep running into the same problem.

I would like to locate "pointless" subpaths and delete them from their parent curve.

Here is my current code:

Sub SubPath()
    On Error Resume Next
    ActiveDocument.BeginCommandGroup "SubPath"
    Dim sr As New ShapeRange
    
    If ActivePage.Shapes.count > 0 Then
        ActiveDocument.Unit = cdrMillimeter
        SubPathEx ActivePage.Shapes, sr
        If sr.count > 0 Then
            sr.CreateSelection
            MsgBox "Found " & sr.count & " shapes.", vbInformation, "SubPath"
        Else
            MsgBox "No shapes found.", vbInformation, "SubPath"
        End If
    Else
        MsgBox "Please create 1 or more like object(s).", vbExclamation, "SubPath"
    End If
    
    ActiveDocument.EndCommandGroup
End Sub

Private Sub SubPathEx(ss As Shapes, sr As ShapeRange)
    Dim s As Shape, sb As SubPath, x As Double, y As Double, sh As New Shape
    
    For Each s In ss
            'Check if group
        If s.Type = cdrGroupShape Then
                'If locked unlock.
            If s.Locked = True Then s.Locked = False
                'Null group name
            s.Name = ""
                'Loop all shapes in the group
            SubPathEx s.Shapes, sr
        Else
                'If locked unlock.
            If s.Locked = True Then s.Locked = False
                'If shape has no fill and no outline delete.
            If s.Fill.Type = cdrNoFill And s.Outline.Type = cdrNoOutline Then
                s.Delete
                'If shape has fill process.
            ElseIf s.Fill.Type <> cdrNoFill Then
                For Each sb In s.Curve.SubPaths
                    If sb.Area < 0.25 Then
                        MsgBox "Width: " & sb.SizeWidth
                        MsgBox "Height: " & sb.SizeHeight
                        MsgBox "Area: " & sb.Area
                        sb.Delete
                    End If
                Next sb
                sr.Add s
            End If
        End If
    Next s
End Sub

This code works great as long as I comment out the sb.Delete. For some reason it leaves the nested For Each after it hits sb.Delete for the first time. However if I remove or comment it the For Each works correctly.

I have found similar results with With the

sb.Segments.All.NodeRange.Delete

Any ideas?

Thanks in advance!

Just tried to extract the subpath with the same result...

sb.Extract s

Hopefully there is a common problem here and I hope its me!

[wOxxOm]

apparently both .Delete and .Extract modify the source array of subpaths which destroys for-each loop.

Here's the most obvious way to circumvent the restriction, yet I haven't tested it :-)

dim i&
.........................
                For i=s.Curve.SubPaths.Count to 1 step -1
                    set sb=s.Curve.SubPaths(i)
                    If sb.Area < 0.25 Then
                        MsgBox "Width: " & sb.SizeWidth
                        MsgBox "Height: " & sb.SizeHeight
                        MsgBox "Area: " & sb.Area
                        sb.Delete
                    End If
                Next sb
                sr.Add s
.........................

[Alex]

Yes, you are right. The current implementation doesn't allow to modify curves in forward loops (and that applies to any changes to curves, like adding/deleting nodes, subpaths, etc). You either do that while looping backwards or you don't do the changes until later. You can create a NodeRange object and add all the nodes of a subpath you want to delete to it. After the loop, you delete all the nodes from that range which will effectively delete all the subpaths that you identifed...

This way you can still do the forward loop and delete all the subpaths in one operations which is faster:

Dim sr As New NodeRange
For Each sp In ...subpaths
   If .... Then
     ...
     sr.AddRange sp.Nodes.All
   End If
Next sp
sr.Delete

Something like that...

[wOxxOm]

dim something as new objecttype - AFAIK VB/VBA underperform in such case, and though it appears slim, yet the most efficient way is to have two lines of code
dim something as objecttype
set something = new objecttype

[Alex]

Originally Posted by wOxxOm

dim something as new objecttype - AFAIK VB/VBA underperform in such case, and though it appears slim, yet the most efficient way is to have two lines of code
dim something as objecttype
set something = new objecttype

I don't know where this information comes from. I haven't noticed a performance difference between the two. In fact, Dim...As New... seems to be a bit more optimized in a sense that it creates an instance of an object only when you first use it. So, if you have a code similar to this:

Dim var As New ObjectType
...
If condition Then
    var.DoSomething
End If

where the object may or may not used depending on the condition, the Dim/New variant will be faster.

I did some tests of my own and, at least for internal VBA classes, the Dim New way seems to perform a bit faster (not by much though)...

Here is what I did. I created a new VBA project in CorelDRAW and inserted a new class module and called it "clsTest" with the following code in it:

Option Explicit

Public Value As Integer

Then in a separate module I added the following code:

Option Explicit

Sub Test()
    Const Count As Long = 100000
    Dim i As Long
    Dim tm As Double
    Dim time1 As Double, time2 As Double
    
    tm = Timer
    For i = 1 To Count
        DoTest1
    Next i
    time1 = Timer - tm
    
    tm = Timer
    For i = 1 To Count
        DoTest2
    Next i
    time2 = Timer - tm
    
    MsgBox "Dim New = " & time1 & " sec" & vbCr & "Dim/Set = " & time2 & " sec"
End Sub

Sub DoTest1()
    Dim c As New clsTest
    c.Value = 10
End Sub

Sub DoTest2()
    Dim c As clsTest
    Set c = New clsTest
    c.Value = 10
End Sub

So the first time is for using "Dim c As New clsTest" and the second one is for "Dim c As clsTest : Set c = New clsTest"

I have the following output:

Dim New = 0.375 sec
Dim/Set = 0.3828125 sec

And that's to invoke DoTest1 and DoTest2 100,000 times each. So, the actual performance of any given single statement is really tiny.

However for creating instances of objects outside of VBA (like those from CorelDRAW), the picture could be different, and for sure creating an instance of NodeRange or Color will be much slower in itself.

[wOxxOm]

this is a very wellknown fact, Alex, just take a little time on either searching with Google or disassemble the VB native exe - for DIM ... AS NEW ... - there is a call to __vbaNew rtc function for EACH ACCESS to the object variable. Of course your examples shown no difference since they're are way too simple :-D but in real cases if you gain 1 second off a 10 sec process thanking to such a basic trick, well I'd say I go for it

Hello Again

So I am thinking that this worked at one point as I remember testing it...

However now even the nr.AddRange sb.Nodes.All it will still break the loop. I will try with a backwards loop and see if that makes a difference.

Thanks!

Sub SubPath()
    On Error Resume Next
    ActiveDocument.BeginCommandGroup "SubPath"
    Dim sr As NodeRange
    Set sr = New NodeRange
    
    If ActivePage.Shapes.count > 0 Then
        ActiveDocument.Unit = cdrMillimeter
        DeSe.SubPathEx ActivePage.Shapes, sr
        If sr.count > 0 Then
            MsgBox "Deleted " & sr.count & " nodes.", vbInformation, "SubPath"
            'sr.Delete
        Else
            MsgBox "No shapes found.", vbInformation, "SubPath"
        End If
    Else
        MsgBox "Please create 1 or more like object(s).", vbExclamation, "SubPath"
    End If
    
    ActiveDocument.EndCommandGroup
End Sub

Private Sub SubPathEx(ss As Shapes, nr As NodeRange)
    Dim s As Shape, sb As SubPath, x As Double, y As Double, sh As New Shape
    
    For Each s In ss
            'Check if group
        If s.Type = cdrGroupShape Then
                'If locked unlock.
            If s.Locked = True Then s.Locked = False
                'Null group name
            s.Name = ""
                'Loop all shapes in the group
            DeSe.SubPathEx s.Shapes, nr
        Else
                'If locked unlock.
            If s.Locked = True Then s.Locked = False
                'If shape has no fill and no outline delete.
            If s.Fill.Type = cdrNoFill And s.Outline.Type = cdrNoOutline Then
                s.Delete
                'If shape has fill process.
            ElseIf s.Fill.Type <> cdrNoFill Then
                For Each sb In s.Curve.SubPaths
                    If sb.Area < 0.25 Then
                        'MsgBox "Width: " & sb.SizeWidth
                        'MsgBox "Height: " & sb.SizeHeight
                        MsgBox "Area: " & sb.Area
                        'sb.Nodes.All.CreateSelection
                        nr.AddRange sb.Nodes.All
                    End If
                Next sb
            End If
        End If
    Next s
End Sub