OberonPlace.com Forums  

Go Back   OberonPlace.com Forums > Corel User Forums > CorelDRAW > Macros/Add-ons

Reply
 
Thread Tools Search this Thread Display Modes
  #1  
Old 27-09-2010, 02:32
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default Auto-group shapes

Hi. I have a macro that will group all shapes. It finds intersected objects and groups them. But macro is working very slowly. Redraws every action. After setting Optimization = true/false strange objects appears in Objects Manager.
How can i speed up this macro ?

undo works much faster than macro
Code:
Private Function CrossShapes(ByRef s1, s2 As Shape) As Boolean
    CrossShapes = True
    If (s1.TopY < s2.BottomY) Or _
    (s1.BottomY > s2.TopY) Or _
    (s1.LeftX > s2.RightX) Or _
    (s1.RightX < s2.LeftX) Then ' level 0, simple check common bounds
        CrossShapes = False
    End If
    'level 1, check every shape in group
    'level 2, check nodes
End Function

Sub AutoGroup()
Dim srPage As ShapeRange
Dim srUnGrouped As ShapeRange
Dim srGroups As ShapeRange
Dim Last As Shape
Dim sChecked As Shape
Dim cnt&, cnt1&, cnt2&
Dim found As Boolean
Dim Aborted As Boolean
Dim stat As AppStatus
    Set srPage = ActivePage.Shapes.All
    Set srUnGrouped = New ShapeRange
    Set srGroups = New ShapeRange
    Set Last = Nothing
    If srPage.Count < 2 Then Exit Sub
    cnt = srPage.Count: ActiveDocument.Unit = cdrMillimeter
    cnt2 = cnt
    EventsEnabled = False
    'Optimization = True
    ActiveDocument.PreserveSelection = False
    
    Set stat = Application.Status: Aborted = False
    stat.BeginProgress "Auto-grouping...", True
    ActiveDocument.BeginCommandGroup "Auto-grouping"
    
    Do While cnt >= 1
        Set sChecked = srPage.Shapes(cnt): found = False
        'If sChecked.Locked = True Then
        ' ignore objects
        ' end
        If Not Last Is Nothing Then
            If CrossShapes(sChecked, Last) Then
                cnt1 = Last.Name
                GoTo ChkGroup
            End If
        End If
        For cnt1 = cnt - 1 To 1 Step -1
            If CrossShapes(sChecked, srPage.Shapes(cnt1)) Then
                srUnGrouped.Add sChecked
                srUnGrouped.Add srPage.Shapes(cnt1)
                srPage.Remove cnt1
                Set Last = srUnGrouped.Group
                srGroups.Add Last
                Last.Name = srGroups.Count
                srUnGrouped.RemoveAll
                cnt = cnt - 1
                found = True
                Exit For
            End If
        Next cnt1
        
        If Not found Then ' check grouped shapes
            For cnt1 = 1 To srGroups.Count
                If CrossShapes(sChecked, srGroups.Shapes(cnt1)) Then
                Set Last = srGroups(cnt1)
ChkGroup:
                    srUnGrouped.Add Last     '.UngroupEx
                    srGroups.Remove cnt1
                    srUnGrouped.Ungroup
                    srUnGrouped.Add sChecked
                    Set Last = srUnGrouped.Group
                    srGroups.Add Last
                    Last.Name = cnt1
                    srUnGrouped.RemoveAll
                    Exit For
                End If
            Next cnt1
        End If
        
        cnt = cnt - 1
        stat.Progress = (cnt2 - cnt) / cnt2 * 100
        If stat.Aborted Then
            Aborted = True
            Exit Do
        End If
    Loop
    If srGroups.Count > 0 Then
        MsgBox "Made are " & srGroups.Count & " groups", , "Auto-grouping"
    Else: MsgBox "No groups"
    End If
    ActiveDocument.PreserveSelection = True
    'Optimization = False
    ActiveDocument.ClearSelection
    'Refresh
    ActiveDocument.EndCommandGroup
    stat.EndProgress
    EventsEnabled = True
End Sub
Thank you in advance for any help

Last edited by shark; 27-09-2010 at 02:41.
Reply With Quote
  #2  
Old 27-09-2010, 21:47
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

HI.
Nice, but it doesn't work with all shapes. I'm guessing you know this. Example attachment would make 2 groups.

Maybe the code I posted in code critique area a while back would work well for this if modified.

The speed seems ok here. Are you using a lot of shapes, like in the thousands?

-John
Attached Images
 
Reply With Quote
  #3  
Old 28-09-2010, 07:02
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default

Hi. Thank you for answer. Sorry for my English
I am agree, macro really don't correctly operates with shapes. It's a simple code. Of course i would add more complex checks of nodes, bitmap crops and other shapes to make universal macro. (Unwritten levels 1 & 2 in CrossShapes). Just i wonder about slow runtime. Attached file of 92 (92x4 shapes) streetsigns takes a lot of time, 19 sec. May be a group/ungroup operations are logging and somehow are increase execution time. In addition, turning on/off Optimization brings to strange unselectable objects in Objects Manager. May be it's a Corel Draw X3 features

P.S. Can't upload file, The service is unavailable
<92 rectangles, frame and pair of curved text lines in each rectangle>
Reply With Quote
  #4  
Old 28-09-2010, 10:25
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Ah. I see what you are using for. Good idea.
Here's my attempt at this. It still uses your crossshapes function.

Code:
Sub myGroupTogether()

Dim s As Shape, s1 As Shape, s2 As Shape, sr As ShapeRange, sr2 As ShapeRange, sr3 As New ShapeRange
Dim x As Double, y As Double, w As Double, h As Double

Set sr = ActivePage.Shapes.All

For Each s In sr
    s.GetBoundingBox x, y, w, h
    s.CreateSelection
    Set sr2 = ActivePage.Shapes.FindShapes(Query:="@com.selected = false And @com.locked = False")
        Set sr3 = Nothing
        For Each s1 In sr2
            If CrossShapes(s, s1) Then sr3.Add s1
            sr3.Add s
        Next s1
        sr3.Group
        For Each s2 In sr3
            s2.Locked = True
        Next s2
Next s
ActivePage.Shapes.FindShapes(Query:="@com.locked = true").Unlock


End Sub

Private Function CrossShapes(ByRef s1, s2 As Shape) As Boolean
    CrossShapes = True
    If (s1.TopY < s2.BottomY) Or _
    (s1.BottomY > s2.TopY) Or _
    (s1.LeftX > s2.RightX) Or _
    (s1.RightX < s2.LeftX) Then ' level 0, simple check common bounds
        CrossShapes = False
    End If
    'level 1, check every shape in group
    'level 2, check nodes
End Function
-John
Reply With Quote
  #5  
Old 29-09-2010, 02:02
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default strangely works

Hello
Your code is definitely looks compact. But, it changes order of shapes. For example, draw rectangle, then draw some shapes inside rectangle and run your code. Attached picture shows it. May be FindShapes(Query:="@com.selected = false And @com.locked = False") CDraw X3 incorrectly performs.
Attached Images
 

Last edited by shark; 29-09-2010 at 02:17.
Reply With Quote
  #6  
Old 29-09-2010, 08:30
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Yes.
The query, which helps give it some speed, does not work in x3.
The macro probably isn't functioning correct.
I'll try to make a multi-version.
-John
Reply With Quote
  #7  
Old 29-09-2010, 14:49
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Try this one:

Code:
Option Explicit

Sub myGroupTogether()

Dim s As Shape, s1 As Shape, s2 As Shape, sr As ShapeRange, sr2 As ShapeRange, sr3 As New ShapeRange
Dim x As Double, y As Double, w As Double, h As Double

Set sr = ActivePage.Shapes.All

For Each s In sr
    s.GetBoundingBox x, y, w, h
    s.CreateSelection
    
    
    If VersionMajor < 14 Then
        Dim s3 As Shape
        Set sr2 = New ShapeRange
        For Each s3 In ActivePage.Shapes.FindShapes
            If s3.Selected = False And s3.Locked = False Then
               sr2.Add s3
            End If
        Next s3
    Else
        Set sr2 = ActivePage.Shapes.FindShapes(Query:="@com.selected = false And @com.locked = False")
    End If
    
        Set sr3 = Nothing
        For Each s1 In sr2
            If CrossShapes(s, s1) Then sr3.Add s1
            sr3.Add s
        Next s1
        sr3.Group
        For Each s2 In sr3
            s2.Locked = True
        Next s2
Next s

If VersionMajor < 14 Then
    Dim s4 As Shape
    For Each s4 In ActivePage.Shapes.FindShapes
        If s4.Locked = True Then s4.Locked = False
    Next s4
Else
    ActivePage.Shapes.FindShapes(Query:="@com.locked = true").Unlock
End If


End Sub

Private Function CrossShapes(ByRef s1, s2 As Shape) As Boolean
    CrossShapes = True
    If (s1.TopY < s2.BottomY) Or _
    (s1.BottomY > s2.TopY) Or _
    (s1.LeftX > s2.RightX) Or _
    (s1.RightX < s2.LeftX) Then ' level 0, simple check common bounds
        CrossShapes = False
    End If
    'level 1, check every shape in group
    'level 2, check nodes
End Function
-John
Reply With Quote
  #8  
Old 04-10-2010, 09:55
shark shark is offline
Senior Member
 
Join Date: Aug 2010
Location: Russia, Belgorod
Posts: 146
Default

Hi
Your code still doesn't correctly works. It creates many included groups and changes order of shapes.
I changed my code and solved a problem. Anyway thankx for you help
Attached Images
 
Reply With Quote
  #9  
Old 04-10-2010, 10:02
runflacruiser's Avatar
runflacruiser runflacruiser is offline
Senior Member
 
Join Date: Jun 2009
Location: Pigeon Forge, TN USA
Posts: 811
Default

Hi.
Hmm.
It must have to do with x3 somehow.
I'm testing on x5 but trying to adapt to x3.
It's interesting.
Thanks.
-John
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
Auto Docker Update ddonnahoe CorelDRAW/Corel DESIGNER VBA 0 29-10-2009 08:13
Auto border macro Spud New product ideas 2 15-03-2009 07:19
Find Group ungroup it then process and again group derasje Macros/Add-ons 2 19-11-2008 04:04
auto date anil_gopalan General 1 29-12-2006 07:38
Auto-Backups won't save to specified dir - v11.0 Anonymous General 1 25-02-2005 15:28


All times are GMT -5. The time now is 07:39.


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