corelvba/UI/frmSelectSame.bas

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSelectSame 
   Caption         =   "相似选择-魔改版 蘭雅"
   ClientHeight    =   5775
   ClientLeft      =   495
   ClientTop       =   5895
   ClientWidth     =   2625
   OleObjectBlob   =   "frmSelectSame.frx":0000
   ShowModal       =   0   'False
End
Attribute VB_Name = "frmSelectSame"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'// This is free and unencumbered software released into the public domain.
'// For more information, please refer to  https://github.com/hongwenjun

'// Attribute VB_Name = "相似选择-魔改版 蘭雅"   frmSelectSame   2023.6.12

Option Explicit
'需要显式声明所有变量。 这可以防止无意中使用缓慢的“Variant”类型变量，这些变量在特定类型未知时使用。
'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.

Public ssreg As ShapeRange

Private Const TOOLNAME As String = "VBA_SelectSame"
Private Const SECTION As String = "Options"

Private Sub btnSelect_Click()
    If 0 = ActiveSelectionRange.Count Then Exit Sub
    On Error GoTo ErrorHandler
    
    Dim fLeft As Double, fTop As Double
    fLeft = frmSelectSame.Left
    fTop = frmSelectSame.Top
    SaveSetting "SelectSame", "Preferences", "form_left", fLeft
    SaveSetting "SelectSame", "Preferences", "form_top", fTop
    
    '// 区域范围选择，需要关闭刷新优化
    If OptBt.value = False Then
      API.BeginOpt
    Else
      add_ssreg
    End If
    
    If (chkFill = False And chkOutline = False And chkOutlineColor = False And _
      chkOutlineLength = False And chkSize = False And chkWHratio = False And _
      chkType = False And chkNodes = False And chkSegments = False And _
      chkPaths = False And chkFontName = False And chkFontSize = False And chkShapeName = False) Then
        MsgBox "请至少选择一个选项", vbCritical, "Select Same"
        GoTo ErrorHandler
    End If


'// "ME"是一个VBA保留字，返回对当前代码所在窗体（或类模块）的引用。 chk... 函数返回同名复选按钮的当前值。
'// "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.
    With Me
      .SelectAllSimilar .chkFill, .chkOutline, .chkOutlineColor, .chkOutlineLength, _
      .chkSize, .chkWHratio, .chkType, .chkNodes, .chkSegments, .chkPaths, _
      .OptDoc, .Optpage, .Optlayer, .chkInGroups, .chkColorMark, .chkIndiv, _
      .chkFontName, .chkFontSize, .chkShapeName
    End With
    
    API.EndOpt
    
Exit Sub
ErrorHandler:
  Application.Optimization = False
End Sub

Sub SelectAllSimilar(Optional CheckFill As Boolean = True, _
                    Optional CheckOutline As Boolean = True, _
                    Optional CheckOutlineColor As Boolean = True, _
                    Optional CheckOutlineLength As Boolean = True, _
                    Optional CheckSize As Boolean = False, _
                    Optional CheckWHratio As Boolean = False, _
                    Optional CheckType As Boolean = True, _
                    Optional CountNodes As Boolean = False, _
                    Optional CountSegments As Boolean = False, _
                    Optional CountPaths As Boolean = False, _
                    Optional WithinDoc As Boolean = False, _
                    Optional WithinPage As Boolean = True, _
                    Optional WithinLayer As Boolean = False, _
                    Optional WithinGroups As Boolean = True, _
                    Optional CheckColorMark As Boolean = False, _
                    Optional CheckIndiv As Boolean = True, _
                    Optional CheckFontName As Boolean = False, _
                    Optional CheckFontSize As Boolean = False, _
                    Optional CheckShapeName As Boolean = False)
                    
    'Object variables.              Reference to:
    Dim shpsSelected As Shapes          'selected shapes,
    Dim shpsToTest As Shapes            'full set of shapes to be tested,  ' 待测形状全部集合
    Dim pagesr As ShapeRange           'pages shapes collection,
    Dim docsr As New ShapeRange
    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. '定义群组内的目标对象
    Dim P As Page, p1 As Page           '文档中查找使用
    Dim shr As ShapeRange, sr As New ShapeRange
    Dim i As Integer  ' '文档中循环查找计数使用
    Dim fsn As Shape  '// 扩展功能: 字体字号标记名检测源对象

    On Error GoTo NothingSelected       'Get a reference to any
    Set shr = ActiveSelectionRange
    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
        

        '// 魔改分支 字体-字号-标记名
        If CheckFontName Or CheckFontSize Or CheckShapeName Then
          Set fsn = shr(1)
        End If

        '===================================
        ' TurnOptimizations cdrOptimizationOn
        '===================================
       
        If WithinPage Then

          If OptBt.value = True Then
            Set shpsToTest = ssreg.Shapes
            OptBt.value = 0
            API.BeginOpt
          Else
            Set shpsToTest = ActivePage.Shapes
          End If
                                            'Ensure that "Edit across layers"
                                            'is ON. Otherwise, selecting
'            Set oScript = CorelScript       'across layers, followed by
'            oScript.SetMultiLayer True      'grouping, can flatten all
'            Set oScript = Nothing           'layers into one. 选中表示将对当前页面的所有对象与源对象进行匹配，否则只匹配当前图层的对象
 
            'Replace the above with this line, CoreScript is not longer support X7+
            ActiveDocument.EditAcrossLayers = True
        End If
        If WithinLayer Then
            Set shpsToTest = ActivePage.ActiveLayer.Shapes
        End If
        
        If WithinDoc Then '在当前文档查找，将当前页面相应的对象加入到待比较范围
            For i = 1 To ActiveDocument.Pages.Count
                ActiveDocument.Pages(i).Activate
                Set p1 = ActiveDocument.Pages(i)
                Set pagesr = ActivePage.SelectShapesFromRectangle(0, p1.CenterY * 2, p1.CenterX * 2, 0, False).Shapes.all
                Debug.Print p1.CenterY * 2 & p1.CenterX * 2
                docsr.AddRange pagesr '各页面依次查找，相应的对象加入到待比较范围
                
            Next i
            Set shpsToTest = docsr.Shapes
'            MsgBox "共有待比较对象 " & shpsToTest.Count & " 个"
            Label13.Caption = "共有待比较对象 " & shpsToTest.Count & " 个"
            'p1.Activate
        End If
        
        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, CheckOutlineLength, CheckSize, CheckWHratio, _
                                CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
                            'shpToMatch.AddToSelection
                            sr.Add shpToMatch
                            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, CheckOutlineLength, CheckSize, CheckWHratio, _
                                CheckType, CountNodes, CountSegments, CountPaths, CheckIndiv) Then
                               'shpToMatch.AddToSelection
                            sr.Add shpToMatch
                            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
        '===================================
        'sr.Add ActiveDocument.Selection
        If CheckColorMark And sr.Count > 0 Then sr.SetOutlineProperties , , CreateCMYKColor(0, 100, 0, 0) '轮廓线上色
        sr.AddRange shr
    
        '// 魔改分支 字体-字号-标记名
        If CheckFontName Or CheckFontSize Or CheckShapeName Then
          If CheckFontName Then ShapesMatch_Font_Name fsn, sr, "FontName"
          If CheckFontSize Then ShapesMatch_Font_Name fsn, sr, "FontSize"
          If CheckShapeName Then ShapesMatch_Font_Name fsn, sr, "ShapeName"
        End If
        
       sr.CreateSelection
        '// 显示找到对象
        Label13.Caption = "共找到 " & sr.Count & " 个对象"
    End If
    
    Set clnModelShapes = Nothing               'Release the memory allocated
    Set shpsToTest = Nothing
    Exit Sub
NothingSelected:
End Sub

'// 添加区域选择分支
Private Function add_ssreg()
    Dim ssr As ShapeRange, shr As ShapeRange
    Dim x1 As Double, y1 As Double, x2 As Double, y2 As Double
    Dim Shift As Long
    Dim b As Boolean
    Set shr = ActiveSelectionRange
    b = ActiveDocument.GetUserArea(x1, y1, x2, y2, Shift, 10, False, cdrCursorWeldSingle)
    If Not b Then
      Set ssreg = ActivePage.SelectShapesFromRectangle(x1, y1, x2, y2, True).Shapes.all
    End If
    ActiveDocument.ClearSelection
    shr.CreateSelection
End Function

'// 魔改分支 字体-字号-标记名  检查匹配
Private Function ShapesMatch_Font_Name(ByVal fsn As Shape, sr As ShapeRange, Check_Case As String)
  Dim xz As String, sh_name As String, strFontName As String
  Dim FontSize As Double
  Dim srText As ShapeRange
  Set srText = sr.Shapes.FindShapes(Type:=cdrTextShape)
      
  Select Case Check_Case
  Case "FontName"
    If fsn.Type = cdrTextShape Then
      strFontName = fsn.text.Story.Font
      Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and @com.text.story.font = '" & strFontName & "'")
    End If
    
  Case "FontSize"
    If fsn.Type = cdrTextShape Then
      FontSize = fsn.text.Story.size
      Set sr = srText.Shapes.FindShapes(Query:="@type ='text:artistic' or @type ='text:paragraph' and (@com.text.story.size - " & FontSize & ").abs() < 0.1 ")
    End If
    
  Case "ShapeName"
    sh_name = fsn.Name
      Set sr = sr.Shapes.FindShapes(Query:="@name ='" & sh_name & "'")
  End Select
End Function


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 CheckOutlineLength As Boolean = True, _
                    Optional CheckSize As Boolean = False, _
                    Optional CheckWHratio As Boolean = False, _
                    Optional CheckType As Boolean = True, _
                    Optional CountNodes As Boolean = False, _
                    Optional CountSegments As Boolean = False, _
                    Optional CountPaths As Boolean = False, _
                    Optional CheckIndiv As Boolean = False) As Boolean
    
    'Sizes "match" if they differ by less than one per cent
    Dim ToleranceSize As Double     '面积大小允许波动
    ToleranceSize = Me.TextBox1 / 100  '面积大小允许波动,以百分比为单位
    
    Dim ToleranceLength As Double   '线长允许波动
    ToleranceLength = Me.TextBox2 / 100 '长度允许波动,以百分比为单位
    
    Dim ToleranceNodesCount As Long  '节点数量允许波动,以 点 单位
    ToleranceNodesCount = Me.TextBox3 '节点数量允许波动,以 点 单位
    
    Dim ToleranceSubPathsCount As Long  '子路径 子线段 允许波动,以 条 为单位
    ToleranceSubPathsCount = Me.TextBox4 '子路径 子线段 允许波动,以 条 为单位
    
    Dim ToleranceWHratio As Double  '长宽比 允许波动,以 百分比 为单位
    ToleranceWHratio = Me.TextBox5  '长宽比 允许波动,以 百分比 为单位
    
    Dim ToleranceSegmentsCount As Long  '线段数 允许波动,以 个 为单位
    ToleranceSegmentsCount = Me.TextBox6 '线段数 允许波动,以 个 为单位
        
    '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.
    Dim spath As SubPath, opath As SubPath
    Dim j As Integer
    
    '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 * _
                 ToleranceSize) Then GoTo NoMatch
            dblHeight = shpModel.SizeHeight
            If Abs(.SizeHeight - dblHeight) > (dblHeight * _
                ToleranceSize) Then GoTo NoMatch
        End If
        
        If CheckWHratio Then               'size width and height ratio differences significant ?
            dblWidth = shpModel.SizeWidth
            dblHeight = shpModel.SizeHeight
            If Abs(.SizeHeight / .SizeWidth - dblHeight / dblWidth) > (dblHeight / dblWidth * ToleranceWHratio) Then GoTo NoMatch
        End If
        

            If CountNodes Or CountPaths Or CheckOutlineLength Or CountSegments Then
                                        'Only Curves can match ...
                If lngShapeType <> cdrCurveShape Then GoTo NoMatch
                
                Set crvShape = .Curve
                Set crvModel = shpModel.Curve
                
                'If CheckIndiv Then '逐条子路径比较
                    'If Abs(crvShape.SubPaths.Count - crvModel.SubPaths.Count) <> 0 Then GoTo NoMatch
                    'For j = 1 To crvShape.SubPaths.Count
                            'If Abs(crvShape.SubPath(j).Nodes.Count - crvModel.SubPath(j).Nodes.Count) > ToleranceNodesCount Then GoTo NoMatch
                     
                     'Next j
                
                If CountPaths Then      'Do the PATH counts match ?
                    
                    If VersionMajor > 12 Then 'GDG ##########################################
                        If Abs(crvShape.SubPaths.Count - crvModel.SubPaths.Count) > ToleranceSubPathsCount Then GoTo NoMatch
                        'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
                    Else
                        If Abs(crvShape.SubPathCount - crvModel.SubPathCount) > ToleranceSubPathsCount Then GoTo NoMatch
                    End If 'GDG #############################################################
                    
                End If
                
                
                 
                 
                If CountNodes Then      'Do the NODE counts match ?
                
                    If VersionMajor > 12 Then 'GDG ##########################################
                        If Abs(crvShape.Nodes.Count - crvModel.Nodes.Count) > ToleranceNodesCount Then GoTo NoMatch
                    Else
                        If Abs(crvShape.NodeCount - crvModel.NodeCount) > ToleranceNodesCount Then GoTo NoMatch
                    End If 'GDG #############################################################
                    
                End If
                
                If CountSegments Then      'Do the Segments counts match ?
                
                    If VersionMajor > 12 Then 'GDG ##########################################
                        If Abs(crvShape.Segments.Count - crvModel.Segments.Count) > ToleranceSegmentsCount Then GoTo NoMatch
                    Else
                        If Abs(crvShape.SegmentCount - crvModel.SegmentCount) > ToleranceSegmentsCount Then GoTo NoMatch
                    End If 'GDG #############################################################
                    
                End If
        
                
                
                If CheckOutlineLength Then      'Do the curve length match ?
                
                    If VersionMajor > 12 Then 'GDG ##########################################
                        If Abs(crvShape.Length - crvModel.Length) > crvModel.Length * ToleranceLength Then GoTo NoMatch
                        'MsgBox "subpaths1: " & crvShape.SubPaths.Count & "subpaths2: " & crvModel.SubPaths.Count
                    Else
                        If Abs(crvShape.Length - crvModel.Length) > crvModel.Length * ToleranceLength Then GoTo NoMatch
                    End If 'GDG #############################################################
                    
                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 ?
                    If VersionMajor > 12 Then 'GDG ##########################################
                        'GDG ##########################################
                        Dim col1 As New Color
                        col1.CopyAssign .UniformColor
                        Dim col2 As New Color
                        col2.CopyAssign shpModel.Fill.UniformColor
                        'GDG ##########################################
                        If col1.IsSame(col2) = False Then GoTo NoMatch
                    Else
                        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  'GDG #############################################################
                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 ?
                            
                            If VersionMajor > 12 Then 'GDG ##########################################
                                'GDG ##########################################
                                Dim col3 As New Color
                                col3.CopyAssign .Color
                                Dim col4 As New Color
                                col4.CopyAssign shpModel.Outline.Color
                                'GDG ##########################################
                                If col3.IsSame(col4) = False Then GoTo NoMatch
                            Else
                                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 If
                    End With
                End If
            End If
        End If
        
    End With
    
    ShapesMatch = True
    Exit Function
    
NoMatch:
    ShapesMatch = False
    
NoMatchExit:
    ShapesMatch = False
    Exit Function
End Function

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 CheckOutlineLength 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


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

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

Private Sub UserForm_Activate()
    Const YES As String = "True"
    Const NO As String = "False"

    OptDoc = GetSetting(TOOLNAME, SECTION, "InDoc", NO)
    Optlayer = GetSetting(TOOLNAME, SECTION, "InLayer", NO)
    Optpage = GetSetting(TOOLNAME, SECTION, "InPage", YES)
    
    chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", YES)
    chkFill = GetSetting(TOOLNAME, SECTION, "Fill", YES)
    chkInGroups = GetSetting(TOOLNAME, SECTION, "InGroups", YES)
    chkNodes = GetSetting(TOOLNAME, SECTION, "Nodes", NO)
    chkSegments = GetSetting(TOOLNAME, SECTION, "Segments", NO)
    chkOutline = GetSetting(TOOLNAME, SECTION, "Outline", YES)
    chkOutlineColor = GetSetting(TOOLNAME, SECTION, "OutlineColor", NO)
    chkOutlineLength = GetSetting(TOOLNAME, SECTION, "OutlineLength", YES)
    chkPaths = GetSetting(TOOLNAME, SECTION, "Paths", NO)
    chkSize = GetSetting(TOOLNAME, SECTION, "Size", NO)
    chkWHratio = GetSetting(TOOLNAME, SECTION, "WHratio", NO)
    chkType = GetSetting(TOOLNAME, SECTION, "Type", YES)
    chkIndiv = GetSetting(TOOLNAME, SECTION, "Indiv", NO)
    chkColorMark = GetSetting(TOOLNAME, SECTION, "ColorMark", NO)
    saveFormPos False
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    saveFormPos True
End Sub

Sub saveFormPos(bDoSave As Boolean)
    Dim dL, dT
    If bDoSave Then 'save position
         SaveSetting TOOLNAME, SECTION, "form_left", Me.Left
         SaveSetting TOOLNAME, SECTION, "form_top", Me.Top
    Else 'place instead.
        dL = GetSetting(TOOLNAME, SECTION, "form_left", 900)
        dT = GetSetting(TOOLNAME, SECTION, "form_top", 200)
        Me.Left = dL: Me.Top = dT
    End If
End Sub

Private Sub OptDoc_Click()
    SaveSetting TOOLNAME, SECTION, "InDoc", CStr(OptDoc)
End Sub
Private Sub Optlayer_Click()
    SaveSetting TOOLNAME, SECTION, "InLayer", CStr(Optlayer)
End Sub
Private Sub Optpage_Click()
    SaveSetting TOOLNAME, SECTION, "InPage", CStr(Optpage)
End Sub
Private Sub chkColorMark_Click()
    SaveSetting TOOLNAME, SECTION, "ColorMark", CStr(chkColorMark)
End Sub
Private Sub chkIndiv_Click()
    SaveSetting TOOLNAME, SECTION, "Indiv", CStr(chkIndiv)
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 chkSegments_Click()
    SaveSetting TOOLNAME, SECTION, "Segments", CStr(chkSegments)
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 chkWHratio_Click()
    SaveSetting TOOLNAME, SECTION, "WHratio", CStr(chkWHratio)
End Sub
Private Sub chkType_Click()
    SaveSetting TOOLNAME, SECTION, "Type", CStr(chkType)
End Sub
Private Sub chkOutLineLength_Click()
    SaveSetting TOOLNAME, SECTION, "OutlineLength", CStr(chkOutlineLength)
End Sub