OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Developer Forums > VBA > Code Critique

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 26-10-2004, 17:03
Peter Clifton
Guest
 
Posts: n/a
Default I think I'm getting better...

Hi

Deleting duplicate shapes

My first attempt at answering this problem some months back worked but was very slow, it took exponentially longer the more shapes there were in a drawing. It didn't really work properly, just made the ultimate task easier. Much quicker than by hand which was what was wanted at the time. I couldn't work out how to delete a shape and continue through the loop without the macro crashing

First newsgroup answer attempt

Code:
    Dim s As Shape
    Dim stest As Shape
    Dim sr As ShapeRange
    
    'Try some speed optimization routines
    Optimization = True
    ActiveDocument.PreserveSelection = False
    
    Set sr = ActiveSelectionRange
    
    'Outside loop steps through each shape
    For Each s In sr
        'If this shape has already been moved skip it
        If s.PositionX <> 0 And s.PositionY <> 0 Then
        'Start another search through each shape in the drawing
        For Each stest In sr
            'If this shape has been moved skip it
            If stest.PositionX <> 0 And stest.PositionY <> 0 Then
                'Test for a few shape parameters to determine if it is similar
                'Other tests possible but these few solved the problem
                If stest.PositionX = s.PositionX And _
                    stest.PositionY = s.PositionY And _
                    stest.Type = s.Type And _
                    stest.SizeHeight = s.SizeHeight And _
                    stest.SizeWidth = s.SizeWidth And _
                    stest.StaticID <> s.StaticID Then
                    'if all tests passed, move the shape off the page
                    stest.SetPosition 0, 0
                    Exit For
                End If
            End If
        Next stest
        End If
    Next s
    
    'remove speed optimization routines
    Optimization = False
    ActiveDocument.PreserveSelection = True
    
    'refresh drawing window
    ActiveDocument.ActiveWindow.Refresh
    
End Sub
And my reason for posting, is the following, I recently realised processing of ranges (doing nothing to the drawing) and working backwards through collections is much quicker. I worked this out today

Code:
Sub DeleteDuplicate()

    Dim s As Shape
    Dim sr As ShapeRange
    Dim i As Integer

    ActiveLayer.Shapes.All.CreateSelection
    
    Set sr = ActiveSelectionRange
    
    'Outside loop steps through each shape
    For Each s In ActiveLayer.Shapes
        'test if shape has already been marked as a duplicate
        If sr.IndexOf(s) <> 0 Then
            'go backwards as you are removing things from a collection
            For i = sr.Count To 1 Step -1
                'add as many tests as you want to determine uniqueness
                If sr(i).PositionX = s.PositionX And _
                    sr(i).PositionY = s.PositionY And _
                    sr(i).Type = s.Type And _
                    sr(i).SizeHeight = s.SizeHeight And _
                    sr(i).SizeWidth = s.SizeWidth And _
                    sr(i).StaticID <> s.StaticID Then
                    sr.Remove i
                End If
            Next i
        End If
    Next s

    'shape range "sr" contains unique shapes so remove it from current selection
    sr.RemoveFromSelection
    
    'delete what is still selected (the duplicates)
    ActiveSelection.Delete
   
End Sub
No doubt it can be made at least 5 times quicker ;-)

Peter
Reply With Quote
  #2  
Old 26-10-2004, 20:21
Alex's Avatar
Alex Alex is offline
Administrator
 
Join Date: Nov 2002
Posts: 1,940
Blog Entries: 4
Default Re: I think I'm getting better...

Peter,

Well done.

Here is a small change which allows to do it even quicker. First, you can use Shape.GetBoundingBox to get the shape position and size in one call.

Also, you don't need to make any selections to do the job.

Then you can get the shape list from the current page or layer and then look though those shapes in a loop. And while at it, start from the beginning of the range in one loop, and then from the current position to the end to compare unique shapes only. You will be comparing any two shapes only once (no need to check for StaticID any more)...

Also cache some of the data beforehand (e.g. get the shape size only once and use the cached values for comparing with the rest of the shapes):

Code:
Sub DeleteDuplicate()
    Dim sr As ShapeRange
    Dim srDup As New ShapeRange
    Dim i As Long, j As Long
    Dim s1 As Shape, s2 As Shape
    Dim x1 As Double, y1 As Double, w1 As Double, h1 As Double
    Dim x2 As Double, y2 As Double, w2 As Double, h2 As Double
    
    Set sr = ActiveLayer.Shapes.All
    
    For i = 1 To sr.Count - 1
        Set s1 = sr(i)
        ' Get the shape position and size in one shot
        s1.GetBoundingBox x1, y1, w1, h1
        For j = i + 1 To sr.Count
            Set s2 = sr(j)
            s2.GetBoundingBox x2, y2, w2, h2
            'add as many tests as you want to determine uniqueness
            If x1 = x2 And y1 = y2 And w1 = w2 And h1 = h2 And s1.Type = s2.Type Then
                srDup.Add s2
            End If
        Next j
    Next i

    srDup.Delete
End Sub
This version works about twice as fast as your last one.

Also you can use CorelDRAW 12's Shape.CompareTo method to simplify some of shape comparisons (you can easily compare fill and outlines too this way):

Code:
Sub DeleteDuplicate12()
    Dim sr As ShapeRange
    Dim srDup As New ShapeRange
    Dim i As Long, j As Long
    Dim s1 As Shape, s2 As Shape
    Dim x1 As Double, y1 As Double
    Dim x2 As Double, y2 As Double
    Dim cmp As cdrCompareType
    
    cmp = cdrCompareFill + cdrCompareOutline + cdrCompareShapeType + _
            cdrCompareShapeWidth + cdrCompareShapeHeight
    
    Set sr = ActiveLayer.Shapes.All
    
    For i = 1 To sr.Count - 1
        Set s1 = sr(i)
        s1.GetPosition x1, y1
        For j = i + 1 To sr.Count
            Set s2 = sr(j)
            s2.GetPosition x2, y2
            If s1.CompareTo(s2, cmp) And x1 = x2 And y1 = y2 Then
                srDup.Add s2
            End If
        Next j
    Next i

    srDup.Delete
End Sub
This works a bit slower but it does compare fills and outlines too which is a big plus.
Reply With Quote
  #3  
Old 27-10-2004, 03:03
Peter Clifton
Guest
 
Posts: n/a
Default

Hi Alex

Only twice as fast, that makes me feel a little better :wink:

I see, a slight reversal in looping logic allowing for one less test.

After my very first Cscript/VBA efforts which had more variables than I could keep track of, I am a little gun shy about adding them to projects now.

I forgot about taking as many processing functions out of the the inner loop which is iterated through the most as being a big time saver, I new about removing calculations but should have realised any calls to Corel methods should be reduced as well.

Must remember about using the GetBoundingBox function for capturing multiple shape properties.

Thanks again

Peter
Reply With Quote
  #4  
Old 27-10-2004, 03:50
Anonymous
Guest
 
Posts: n/a
Default

Alex

Just tried out your answer.

My test document which is created as follows

Draw about 20 circles randomly on a page. Duplicate the 20 circles (in place) until there are around 4000 shapes in the drawing.

Running your example took around 50 seconds. My second posted example took around 5 seconds.

I think it has something to do with my 'test if shape is in range', but can't work out where to try inserting this test in your second example.

Peter
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


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


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