OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > CorelDRAW/Corel DESIGNER VBA

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 21-02-2008, 19:01
m31uk3
Guest
 
Posts: n/a
Default 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:

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

Code:
sb.Segments.All.NodeRange.Delete
Any ideas?

Thanks in advance!
Reply With Quote
  #2  
Old 21-02-2008, 19:12
m31uk3
Guest
 
Posts: n/a
Default

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

Code:
sb.Extract s
Hopefully there is a common problem here and I hope its me!
Reply With Quote
  #3  
Old 22-02-2008, 00:40
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

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 :-)
Code:
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
.........................
Reply With Quote
  #4  
Old 22-02-2008, 11:37
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,941
Blog Entries: 4
Default

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:

Code:
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...
Reply With Quote
  #5  
Old 22-02-2008, 17:07
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

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
Reply With Quote
  #6  
Old 24-02-2008, 22:09
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,941
Blog Entries: 4
Default

Quote:
Originally Posted by wOxxOm View Post
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:

Code:
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:

Code:
Option Explicit

Public Value As Integer
Then in a separate module I added the following code:

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:

Quote:
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.
Reply With Quote
  #7  
Old 24-02-2008, 22:33
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

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
Reply With Quote
  #8  
Old 20-06-2008, 12:28
m31uk3
Guest
 
Posts: n/a
Default

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!


Code:
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
Reply With Quote
Reply


Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)
 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is On
Smilies are On
[IMG] code is On
HTML code is Off

Forum Jump

Similar Threads
Thread Thread Starter Forum Replies Last Post
A script for joining overlapping nodes? zhuyan166 CurveWorks 0 22-05-2006 02:58
Select all nodes if the subpath d-signer CorelDRAW/Corel DESIGNER VBA 2 13-05-2004 00:47


All times are GMT -5. The time now is 04:21.


Powered by vBulletin® Version 3.8.1
Copyright ©2000 - 2022, Jelsoft Enterprises Ltd.
Copyright © 2011, Oberonplace.com