Option Explicit         'Requires explicit declaration of all
                        'variables. This protects against
                        'inadvertent use of the slow 'Variant' type
                        'variables which are used when the specific
                        'type is unknown.
                        
Private Const TOOLNAME As String = "VBA_SelectSame"
Private Const SECTION As String = "Options"


'User
'    UserForm_Activate
'    chkActiveOnly_Click
'    chkFill_Click
'    chkInGroups_Click
'    chkNodes_Click
'    chkOutline_Click
'    chkPaths_Click
'    chkSize_Click
'    chkType_Click
'    btnSelect_Click
'        SelectAllSimilar
'            FlatShapeList
'                ShapesInGroup
'    SelectSimilar
'        ShapesMatch
'            GroupsMatch
    

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Calls SelectAllSimilar() passing to it a set of flags
 '          specifying which aspects of similarity to consider,
 '          and on which drawing layers shapes can be selected.
 ' Called:  by User() clicking btnSelect button on this form.
 ' Inputs:  On/off state of eight check-buttons on this form.
 ' Author:  Robin Trew,  Cambridge, England.
 ' Created: 1999,Jul 26
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Private Sub btnSelect_Click()

    With Me             '"Me" is a VBA reserved word, returning a
                        'reference to the form (or class module)
                        'in which the current code is located.
                        'The chk... functions return the current
                        'Value of the check buttons of the same
                        'name.
        .SelectAllSimilar .chkFill, .chkOutline, .chkOutlineColor, _
            .chkSize, .chkType, .chkNodes, .chkPaths, _
            Not .chkActiveOnly, .chkInGroups
    End With
    
End Sub

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Extends selection to all shapes which are "similar" to
 '          any of of those that are pre-selected. The elements of
 '          similarity to be taken into account, and the set of
 '          shapes to be considered, are determined by the state of
 '          a number of input flags.
 ' Called:  by btnSelect_Click()
 ' Inputs:  CheckFill: Require similar fill ?
 '          CheckOutLine: Require similar line color/width etc ?
 '          CheckSize: Require similar shape size ?
 '          CheckType: Require same shape type ?
 '          CountNodes: Require matching node-count in curves ?
 '          CountPaths: Require matching # of paths in curves ?
 '          AcrossLayers: Select shapes in *all* visible layers ?
 '          WithinGroups: Select shapes that are inside groups ?
 ' Author:  Robin Trew, Cambridge, England.
 ' Created: 1999 Jul 26    Last Edited: 1999 Aug 13, 6:11pm
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                    Optional CheckOutline As Boolean = True, _
                    Optional CheckOutlineColor As Boolean = True, _
                    Optional CheckSize As Boolean = False, _
                    Optional CheckType As Boolean = True, _
                    Optional CountNodes As Boolean = False, _
                    Optional CountPaths As Boolean = False, _
                    Optional AcrossLayers As Boolean = True, _
                    Optional WithinGroups As Boolean = True)
                    
    'Object variables.              Reference to:
    Dim shpsSelected As Shapes          'selected shapes,
    Dim shpsToTest As Shapes            'full set of shapes to be tested,
    Dim shpModel As Shape               'a pre-selected shape,
    Dim shpToMatch As Shape             'a shape to be matched,
    Dim oScript As Object               'CorelScript object,
    Dim clnModelShapes As Collection    'our list of pre-selected shapes,
    Dim clnSubShapes As Collection      'our list of shapes inside a group.
    
                                            
    On Error GoTo NothingSelected       'Get a reference to any
    Set shpsSelected = ActiveDocument.Selection.Shapes
    On Error GoTo 0                     'pre-selected shapes.
    
    If shpsSelected.Count > 0 Then          'Gather the pre-selected shapes
        Set clnModelShapes = New Collection 'into a new collection for
        For Each shpModel In shpsSelected   'simple processing.
           clnModelShapes.Add shpModel
        Next
        
        '===================================
        ' TurnOptimizations cdrOptimizationOn
        '===================================
        
Set shpsToTest = ActivePage.SelectableShapes.All
        
        If WithinGroups Then                'Check through flattened list.
            Set clnSubShapes = FlatShapeList(shpsToTest)
            '=======
            For Each shpToMatch In clnSubShapes
                If Not shpToMatch.Selected Then 'If the shape is not yet selected,
                
                   '====================     'check the models for a match.
                    For Each shpModel In clnModelShapes
                        If ShapesMatch(shpToMatch, shpModel, CheckFill, _
                                CheckOutline, CheckOutlineColor, CheckSize, _
                                CheckType, CountNodes, CountPaths) Then
                            shpToMatch.AddToSelection
                            Exit For        'If a match has now been found,
                        End If              'we can skip any remaining models.
                    Next
                   '=====================
                   
                End If
            Next
            '=======
        Else                                'Check through top-level list.
            For Each shpToMatch In shpsToTest
                If Not shpToMatch.Selected Then 'If the shape is not yet selected,
                                            'check the models for a match.
                    For Each shpModel In clnModelShapes
                        If ShapesMatch(shpToMatch, shpModel, CheckFill, _
                                CheckOutline, CheckOutlineColor, CheckSize, _
                                CheckType, CountNodes, CountPaths) Then
                            shpToMatch.AddToSelection
                            Exit For        'If a match has now been found,
                        End If              'we can skip any remaining models.
                    Next
                    
                End If
            Next
        End If
            
        '===================================
       ' TurnOptimizations cdrOptimizationOff
        CorelScript.RedrawScreen
        '===================================
    End If
                                               
    
    
    Set clnModelShapes = Nothing               'Release the memory allocated
    Set shpsToTest = Nothing
    Exit Sub
NothingSelected:
End Sub

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Establishes whether a given pair of shapes are "similar"
 '          in whichever respects are specified to be relevant.
 ' Called:  by SelectSimilar()
 ' Inputs:  CheckFill:      Require similar fill ?
 '          CheckOutLine:   Require similar line color/width etc. ?
 '          CheckSize:      Require similar shape size ?
 '          CheckType:      Require same shape type ?
 '          CountNodes:     Require matching node-count in curves ?
 '          CountPaths:     Require matching no. of paths in curves ?
 ' Outputs: TRUE if the shapes are similar, otherwise FALSE.
 ' Author:  Robin Trew, 1999 July 26, Cambridge, England.
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function ShapesMatch(shpShape As Shape, shpModel As Shape, _
                    Optional CheckFill As Boolean = True, _
                    Optional CheckOutline As Boolean = True, _
                    Optional CheckOutlineColor As Boolean = True, _
                    Optional CheckSize As Boolean = False, _
                    Optional CheckType As Boolean = True, _
                    Optional CountNodes As Boolean = False, _
                    Optional CountPaths As Boolean = False) As Boolean
    
    'Sizes "match" if they differ by less than one per cent
    Const TOLERANCE = 0.01
        
    'Object Variables.        'Reference to:
    Dim clrModel As Color           'color features of model shape,
    Dim clrShape As Color           'color features of shape to be tested
    Dim fillModel As Fill           'fill style of model shape,
    Dim outlnModel As Outline       'outline style of model shape,
    Dim crvModel As Curve           'Bezier curve of model shape,
    Dim crvShape As Curve           'Bezier curve of shape to be tested,
    Dim fntModel As StructFontProperties  'font properties of model text shape,
    Dim trgModel As Text            'general text properties of model shape.
    
    'Simple Variables.              Storage of:
    Dim dblWidth As Double              'width of a shape,
    Dim dblHeight As Double             'height of a shape,
    Dim lngShapeType As cdrShapeType    'code for type of shape to be tested,
    Dim lngModelType As cdrShapeType    'code for the type of a model shape,
    Dim lngType As Long                 'code for the type of a fill, color,
                                        'or outline.
                                        
    
                                        'Does the SHAPE match the MODEL ?
                                        'Exit immediately on any mismatch.
    With shpShape
        lngShapeType = .Type            'Same basic TYPE of shape ?
        lngModelType = shpModel.Type
        
        If CheckType Then If lngShapeType <> lngModelType Then GoTo NoMatch
                                        'A GROUP ? delegate to GroupsMatch()
        If lngShapeType = cdrGroupShape Then
            ShapesMatch = GroupsMatch(shpShape, shpModel, CheckSize, _
                                CountNodes, CountPaths)
            Exit Function
        End If
                                        'Does SIZE count ? Is so, are the
        If CheckSize Then               'size differences significant ?
            dblWidth = shpModel.SizeWidth
            If Abs(.SizeWidth - dblWidth) > (dblWidth * _
                 TOLERANCE) Then GoTo NoMatch
            dblHeight = shpModel.SizeHeight
            If Abs(.SizeHeight - dblHeight) > (dblHeight * _
                TOLERANCE) Then GoTo NoMatch
        End If
                                        'NODE and PATH tests are relevant
                                        'only if the model is a curve.
        If lngModelType = cdrCurveShape Then
            If CountNodes Or CountPaths Then
                                        'Only Curves can match ...
                If lngShapeType <> cdrCurveShape Then GoTo NoMatch
                
                Set crvShape = .Curve
                Set crvModel = shpModel.Curve
                 
                If CountNodes Then      'Do the NODE counts match ?
                    If crvShape.Nodes.Count <> crvModel.Nodes.Count _
                        Then GoTo NoMatch
                End If
        
                If CountPaths Then      'Do the PATH counts match ?
                    If crvShape.SubPaths.Count <> crvModel.SubPaths.Count _
                        Then GoTo NoMatch
                End If
            End If
        End If

        If CheckFill Then
            Set fillModel = shpModel.Fill
            With .Fill                  'Is the FILL type the same ?
                lngType = .Type
                If lngType <> shpModel.Fill.Type Then GoTo NoMatch
                If lngType = cdrUniformFill Then
                                        'Does the uniform fill match ?
                    Set clrModel = fillModel.UniformColor
                    lngType = .UniformColor.Type
                    If lngType <> clrModel.Type Then GoTo NoMatch
                    If .UniformColor.Name(True) <> _
                        clrModel.Name(True) Then GoTo NoMatch
                End If
            End With
        End If
        
        If CheckOutline Then            '(Groups have no outline)
            If lngShapeType <> cdrGroupShape Then
                Set outlnModel = shpModel.Outline
                If Not outlnModel Is Nothing Then
                    With .Outline
                        lngType = .Type
                        If lngType <> outlnModel.Type Then GoTo NoMatch
                                                
                        If lngType > 0 Then     'Does the shape have an OUTLINE ?
                                                'Same LINE WIDTH ?
                            If .Width <> outlnModel.Width Then GoTo NoMatch
                                                'Matching LINE COLOR ?
                            Set clrShape = .Color
                            lngType = clrShape.Type
                            Set clrModel = outlnModel.Color
                            If lngType <> clrModel.Type Then GoTo NoMatch
                            If clrShape.Name(True) <> clrModel.Name(True) _
                                Then GoTo NoMatch
                        End If
                    End With
                End If
            End If
        End If
        
        If CheckOutlineColor Then            '(Groups have no outline)
            If lngShapeType <> cdrGroupShape Then
                Set outlnModel = shpModel.Outline
                If Not outlnModel Is Nothing Then
                    With .Outline
                        lngType = .Type
                        If lngType <> outlnModel.Type Then GoTo NoMatch
                                                
                        If lngType > 0 Then     'Does the shape have an OUTLINE ?
                                                'Matching LINE COLOR ?
                            Set clrShape = .Color
                            lngType = clrShape.Type
                            Set clrModel = outlnModel.Color
                            If lngType <> clrModel.Type Then GoTo NoMatch
                            If clrShape.Name(True) <> clrModel.Name(True) _
                                Then GoTo NoMatch
                        End If
                    End With
                End If
            End If
        End If
                                        'Is there any TEXT ?
        If lngModelType = cdrTextShape Then
            Set trgModel = shpModel.Text
            With .Text
                If .Type <> trgModel.Type Then GoTo NoMatch
                                        'Does the FONT match ?
                Set fntModel = trgModel.FontProperties
                With .FontProperties
                    If .Name <> fntModel.Name Then GoTo NoMatch
                    If .Size <> fntModel.Size Then GoTo NoMatch
                End With
            End With
        End If
    End With
    
    ShapesMatch = True
    Exit Function
    
NoMatch:
    ShapesMatch = False
End Function

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Establishes whether a given pair of groups are "similar"
 '          in whichever respects are specified to be relevant.
 ' Called:  by ShapesMatch() when a model shape proves to be
 '          a cdrGroupShape.
 ' Inputs:  CheckFill:      Require similar fill ?
 '          CheckOutLine:   Require similar line color/width etc. ?
 '          CheckSize:      Require similar shape size ?
 '          CheckType:      Require same shape type ?
 '          CountNodes:     Require matching node-count in curves ?
 '          CountPaths:     Require matching no. of paths in curves ?
 ' Outputs: TRUE if the groups are similar, otherwise FALSE.
 ' Author:  Robin Trew, 1999 July 26, Cambridge, England.
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function GroupsMatch(Group As Shape, GroupModel As Shape, _
                    Optional CheckFill As Boolean = True, _
                    Optional CheckOutline As Boolean = True, _
                    Optional CheckOutlineColor As Boolean = True, _
                    Optional CheckSize As Boolean = False, _
                    Optional CheckType As Boolean = True, _
                    Optional CountNodes As Boolean = False, _
                    Optional CountPaths As Boolean = False) As Boolean
    
    'Object Variables.              Reference to:
    Dim shpsModels As Shapes            'shapes in the pre-selected group,
    Dim shpsInGroup As Shapes           'shapes in the group to be tested,
    Dim shpModel As Shape               'a shape in the pre-selected group,
    Dim shpInGroup As Shape             'a shape in the group to be tested.
    
    'Simple Variables               Storage of:
    Dim lngInGroup As Long              'number of shapes in a group,
    Dim i As Long                       'a numeric index to a
                                        'particular sub-group.
                                        
    'On Error GoTo NoMatch              'Shape & model must be groups.
    Set shpsModels = GroupModel.Shapes
    Set shpsInGroup = Group.Shapes
    'On Error GoTo 0
                                        'Same number of shapes
    lngInGroup = shpsModels.Count       'in each group ?
    If shpsInGroup.Count <> lngInGroup Then GoTo NoMatch
        
    For i = 1 To lngInGroup             'Try to Match all sub-shapes,
        Set shpInGroup = shpsInGroup(i) 'and GroupsMatch all sub-groups.
        Set shpModel = shpsModels(i)
        
        If shpModel.Type <> cdrGroupShape Then
            If Not ShapesMatch(shpInGroup, shpModel, _
                            CheckSize, CountNodes) Then GoTo NoMatch
        Else
            If Not GroupsMatch(shpInGroup, shpModel, _
                            CheckSize, CountNodes) Then GoTo NoMatch
        End If
    Next i
    
    GroupsMatch = True
    Exit Function
NoMatch:
    GroupsMatch = False
End Function

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Assembles a list of ALL the shapes which are members or
 '          descendants (nested inside groups) of a given .Shapes
 '          collection.
 ' Called:  by SelectAllSimilar(), if the "Inside Groups" option of
 '          the SelectSame tool is checked.
 ' Inputs:  TopLevelShapes - a CorelDRAW.Shapes collection,
 '          referencing the shapes on a particular Page or Layer.
 ' Outputs: A collection containing keyed references to shapes.
 ' Author:  Robin Trew, Cambridge, England.
 ' Created: 1999 Jul 26    Last Edited: 1999 Aug 5, 8:59am
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function FlatShapeList(TopLevelShapes As Shapes) As Collection
    
    'Object Variables.          Reference to:
    Dim shpTopLevel As Shape        'a top-level shape,
    Dim shpInGroup As Shape         'a shape inside a group,
    Dim clnAllShapes As Collection  'our list of all members and
                                    'descendants of TopLevelShapes.
                                       
    If TopLevelShapes.Count Then
        Set clnAllShapes = New Collection
        For Each shpTopLevel In TopLevelShapes
                                    'Add shape to list, keyed under
                                    'a string version of its unique ID
             clnAllShapes.Add shpTopLevel
                                    'If the shape is a group, then
                                    'also gather all its descendants
                                    'and add them to the list.
            If shpTopLevel.Type = cdrGroupShape Then
                For Each shpInGroup In ShapesInGroup(shpTopLevel)
               clnAllShapes.Add shpInGroup
                Next
            End If
        Next
        Set FlatShapeList = clnAllShapes  'Return the assembled collection.
    Else
        Set FlatShapeList = Nothing
    End If
End Function

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Recursively drills down to the deepest level of group
 '          nesting to collect a full list of the sub-groups and
 '          terminal leaf shapes contained inside a particular group
 '          shape.
 ' Called:  by FlatShapeList()
 ' Inputs:  GroupShape: A shape of type cdrGroupShape
 ' Outputs: A collection containing references to shapes.
 ' Author:  Robin Trew. Cambridge, England.
 ' Created: 1999 Jul 26    Last Edited: 1999 Aug 5, 8:56am
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function ShapesInGroup(GroupShape As Shape) As Collection

    'Object Variables.              Reference to:
    Dim shpsInGroup As Shapes           'the set of shapes inside a group,
    Dim shpInGroup As Shape             'a particular shape in a group,
    Dim shpNested As Shape              'a shape inside a sub-group,
    Dim clnShapeList As Collection      'our list of all nested shapes.
    
    If GroupShape.Type = cdrGroupShape Then
        Set shpsInGroup = GroupShape.Shapes 'Get a reference to the
                                            'shapes in this group.
        Set clnShapeList = New Collection
        For Each shpInGroup In shpsInGroup
            clnShapeList.Add shpInGroup     'Add all shapes in the group to
                                            'our main collection.
            If shpInGroup.Type = cdrGroupShape Then
                                            'Recurse to get nested shapes.
                For Each shpNested In ShapesInGroup(shpInGroup)
                    clnShapeList.Add shpNested
                Next
            End If
        Next
        Set ShapesInGroup = clnShapeList    'Return the assembled collection.
    Else
        Set ShapesInGroup = Nothing         'Release the memory if the
    End If                                  'collection is not needed
End Function

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: Retrieve option settings from the registry. Uses
 '          defaults if no saved settings are found.
 ' Called:  by User() whenever the SelectSame tool is activated.
 ' Inputs:  Any settings automatically saved in the registry by a
 '          previous session (see check-box _Click events below).
 ' Author:  Robin Trew. Cambridge, England.
 ' Created: 1999 Aug 5, 8:43am    Last Edited: 1999 Aug 13, 6:06pm
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub UserForm_Activate()
    Const YES As String = "True"
    Const NO As String = "False"
                                        
    chkActiveOnly = GetSetting(TOOLNAME, SECTION, "ActiveOnly", NO)
    chkFill = GetSetting(TOOLNAME, SECTION, "Fill", YES)
    chkInGroups = GetSetting(TOOLNAME, SECTION, "InGroups", YES)
    chkNodes = GetSetting(TOOLNAME, SECTION, "Nodes", NO)
    chkOutline = GetSetting(TOOLNAME, SECTION, "Outline", YES)
    chkOutlineColor = GetSetting(TOOLNAME, SECTION, "OutlineColor", NO)
    chkPaths = GetSetting(TOOLNAME, SECTION, "Paths", NO)
    chkSize = GetSetting(TOOLNAME, SECTION, "Size", NO)
    chkType = GetSetting(TOOLNAME, SECTION, "Type", YES)
End Sub

 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 ' Purpose: (Check-box _Click events): whenever an option on the
 '          SelectSame tool is changed, the new setting is saved in
 '          the Windows registry, to be reloaded when the tool is
 '          next activated.
 ' Outputs: Settings in the registry under
 '          TOOLNAME_SECTION_OptionName (Value = "True"/"False")
 ' Notes:   (see TOOLNAME and SECTION module constants)
 ' Author:  Robin Trew. Cambridge, England.
 ' Created: 1999 Aug 5, 8:48am    Last Edited: 1999 Aug 5, 8:56am
 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub chkActiveOnly_Click()
    SaveSetting TOOLNAME, SECTION, "ActiveOnly", CStr(chkActiveOnly)
End Sub
Private Sub chkFill_Click()
    SaveSetting TOOLNAME, SECTION, "Fill", CStr(chkFill)
End Sub
Private Sub chkInGroups_Click()
    SaveSetting TOOLNAME, SECTION, "InGroups", CStr(chkInGroups)
End Sub
Private Sub chkNodes_Click()
    SaveSetting TOOLNAME, SECTION, "Nodes", CStr(chkNodes)
End Sub
Private Sub chkOutline_Click()
    SaveSetting TOOLNAME, SECTION, "Outline", CStr(chkOutline)
End Sub
Private Sub chkOutlineColor_Click()
    SaveSetting TOOLNAME, SECTION, "OutlineColor", CStr(chkOutlineColor)
End Sub
Private Sub chkPaths_Click()
    SaveSetting TOOLNAME, SECTION, "Paths", CStr(chkPaths)
End Sub
Private Sub chkSize_Click()
    SaveSetting TOOLNAME, SECTION, "Size", CStr(chkSize)
End Sub
Private Sub chkType_Click()
    SaveSetting TOOLNAME, SECTION, "Type", CStr(chkType)
End Sub