#1




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 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 Peter 
#2




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




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




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 
Currently Active Users Viewing This Thread: 1 (0 members and 1 guests)  
Thread Tools  Search this Thread 
Display Modes  

