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 27-09-2006, 15:56
hywelgharris
Guest
 
Posts: n/a
Default Selecting duplicate objects

I occasionally need to find and delete duplicate objects stacked on top of one another. How would I go about doing this with a macro?

TIA

Hywel Harris
Reply With Quote
  #2  
Old 28-09-2006, 05:39
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

I use this for ages...

Code:
Sub removeUnderlyingDups()
   Dim s As Shape, sr As New ShapeRange, props() As Double
   Dim toDEL As New ShapeRange, stat As AppStatus, pr As Double, cnt&, idx&, _
       x As Double, y As Double, w As Double, h As Double, n&, match%, i&
   
   pr = 0.00001
   If ActiveShape Is Nothing Then Set sr = ActivePage.FindShapes _
      Else Set sr = ActiveSelectionRange.shapes.FindShapes
   If sr.Count = 0 Then Exit Sub
   ReDim props(1 To sr.Count, 1 To 5): cnt = 0: idx = 0
   Set stat = Application.Status
   stat.BeginProgress "Looking for curve duplicates...", True
   Optimization = True
   EventsEnabled = False
   ActiveDocument.SaveSettings
   ActiveDocument.PreserveSelection = False

   For Each s In sr
      idx = idx + 1: stat.Progress = idx / sr.Count * 100
      If stat.Aborted Then Exit For
      x = s.PositionX: y = s.PositionY: n = s.Curve.Nodes.Count
      w = s.SizeWidth: h = s.SizeHeight: match = False
      For i = 1 To cnt
         If stat.Aborted Then Exit For
         If Abs(props(i, 1) - x) < pr Then _
            If Abs(props(i, 2) - y) < pr Then _
               If Abs(props(i, 3) - w) < pr Then _
                  If Abs(props(i, 4) - h) < pr Then _
                     If props(i, 5) = n Then _
                        toDEL.Add s: match = True: Exit For
      Next i
      If Not match Then
         cnt = cnt + 1: props(cnt, 1) = x: props(cnt, 2) = y
         props(cnt, 3) = w: props(cnt, 4) = h: props(cnt, 5) = n
      End If
   Next s

   ActiveDocument.PreserveSelection = True
   ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   Application.CorelScript.RedrawScreen

   If toDEL.Count = 0 Then Exit Sub
   toDEL.CreateSelection
   If MsgBox("Confirm delete " + CStr(toDEL.Count) + " objects", vbOKCancel) = vbOK Then _
      toDEL.Delete
End Sub
Reply With Quote
  #3  
Old 28-09-2006, 06:03
hywelgharris
Guest
 
Posts: n/a
Default Delete dupes

Thanks Os.
Reply With Quote
  #4  
Old 09-11-2006, 15:06
LGD
Guest
 
Posts: n/a
Default

Hey, that's great, will come in handy.... but it seems to have problems if there's a rectangle or circle on the page :-(

LD
Reply With Quote
  #5  
Old 23-11-2006, 06:39
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

Quote:
Originally Posted by LGD
Hey, that's great, will come in handy.... but it seems to have problems if there's a rectangle or circle on the page :-(
it is because it was intended for curves only... just a sketch of macro,
here is the version for X3 only, it uses .DisplayCurve property to count node count to make decision of identity

Code:
Sub removeUnderlyingDups()
   Dim s As Shape, sr As New ShapeRange, props() As Double
   Dim toDEL As New ShapeRange, stat As AppStatus, pr As Double, cnt&, idx&, _
       x As Double, y As Double, w As Double, h As Double, n&, match%, i&
   
   pr = 0.00001
   If ActiveShape Is Nothing Then Set sr = ActivePage.FindShapes _
      Else Set sr = ActiveSelectionRange.shapes.FindShapes
   If sr.Count = 0 Then Exit Sub
   ReDim props(1 To sr.Count, 1 To 5): cnt = 0: idx = 0
   Set stat = Application.Status
   stat.BeginProgress "Looking for curve duplicates...", True
   Optimization = True
   EventsEnabled = False
   ActiveDocument.SaveSettings
   ActiveDocument.PreserveSelection = False

   For Each s In sr
      idx = idx + 1: stat.Progress = idx / sr.Count * 100
      If stat.Aborted Then Exit For
      x = s.PositionX: y = s.PositionY: n = s.DisplayCurve.Nodes.Count
      w = s.SizeWidth: h = s.SizeHeight: match = False
      For i = 1 To cnt
         If stat.Aborted Then Exit For
         If Abs(props(i, 1) - x) < pr Then _
            If Abs(props(i, 2) - y) < pr Then _
               If Abs(props(i, 3) - w) < pr Then _
                  If Abs(props(i, 4) - h) < pr Then _
                     If props(i, 5) = n Then _
                        toDEL.Add s: match = True: Exit For
      Next i
      If Not match Then
         cnt = cnt + 1: props(cnt, 1) = x: props(cnt, 2) = y
         props(cnt, 3) = w: props(cnt, 4) = h: props(cnt, 5) = n
      End If
   Next s

   ActiveDocument.PreserveSelection = True
   ActiveDocument.RestoreSettings
   EventsEnabled = True
   Optimization = False
   Application.CorelScript.RedrawScreen

   If toDEL.Count = 0 Then Exit Sub
   toDEL.CreateSelection
   If MsgBox("Confirm delete " + CStr(toDEL.Count) + " objects", vbOKCancel) = vbOK Then _
      toDEL.Delete
End Sub
Reply With Quote
  #6  
Old 20-12-2006, 14:55
LGD
Guest
 
Posts: n/a
Default

Looks like text trips it up too........... :-( Essentially, I have a bunch of files where the object types are mixed, could be rectangles, circles, text, curves, polygons, bitmaps, etc. Some of the objects in there are duplicates, so far, I've only run across dupes that are curves, but they are mixed in with other object types. Works fine if I select everything, then weed out the text. Haven't actually tried it on a file that has any bitmaps or polygons yet. I only use these types of files when I absolutely have to, they were imported by someone else (who had no clue) and are generally a mess. Then, after the import, things were added, changed, etc.

LD

Last edited by LGD; 20-12-2006 at 15:14.
Reply With Quote
  #7  
Old 20-12-2006, 15:04
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,782
Blog Entries: 11
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default GMS and Marco

This will show you how to create a GMS:

Alex's How to create a new GMS module

and this shows how to create a new macro, just use your GMS instead of the GlobalMacros.

Creating a new VBA macro

Hope that helps,

Shelby
Reply With Quote
  #8  
Old 20-12-2006, 17:13
wOxxOm's Avatar
wOxxOm wOxxOm is offline
Senior Member
 
Join Date: Mar 2005
Posts: 836
Default

To quickselect everything except text - make button for Edit-select-text, then run InvertSelection macro, it's somewhere in this forum. I spend one second using these!
Reply With Quote
  #9  
Old 21-12-2006, 07:53
LGD
Guest
 
Posts: n/a
Default

Quote:
Originally Posted by wOxxOm
To quickselect everything except text - make button for Edit-select-text, then run InvertSelection macro, it's somewhere in this forum. I spend one second using these!
Excellent! Thanks! You know, I keep forgetting those "Select all...." menus.

OK, I'm trying to make this a "one-stop-shop" by combining all the methods needed to just run the macro and let it do it's thing. I'd like it to select everything but the text on the page, then find the duplicates. Seems I can't find a simple way to just select all the text on the page from the macro, the way the Edit... Select... Text menu does. You'd think that would be simple, but... either it is and I'm so dense I'm missing it, or it's strangely buried. I already tried recording a macro of just the menu actions, but the macro turns up blank.

LD

Last edited by LGD; 21-12-2006 at 09:40.
Reply With Quote
  #10  
Old 21-12-2006, 11:31
shelbym's Avatar
shelbym shelbym is offline
Senior Member
 
Join Date: Nov 2002
Location: Cheyenne, WY
Posts: 1,782
Blog Entries: 11
Send a message via ICQ to shelbym Send a message via AIM to shelbym Send a message via MSN to shelbym Send a message via Yahoo to shelbym
Default Selecting Text

Try this:
Code:
Sub SelectAllText()

Dim sr As ShapeRange

Set sr = ActivePage.FindShapes(Type:=cdrTextShape)
sr.CreateSelection

End Sub
Good luck,

Shelby
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
selecting objects in a group bloodgroove General 2 19-01-2006 12:11
Selecting objects overlapped by other objects Alex FAQ 1 16-05-2005 14:38
Default offset for Duplicate objects Alex FAQ 0 27-04-2005 11:13
I need to update objects visibility faster NEHovis Corel Photo-Paint VBA 0 18-07-2003 07:54
VBA Script for CD 11 - Selecting objects with same color Superfreak CorelDRAW/Corel DESIGNER VBA 4 28-01-2003 11:33


All times are GMT -5. The time now is 03:01.


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