Auto-group shapes

[shark]

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

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

[runflacruiser]

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

[shark]

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>

[runflacruiser]

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

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

[shark]

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.

[runflacruiser]

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

[runflacruiser]

Try this one:

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

[shark]

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

[runflacruiser]

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