2Dｺﾝﾎﾟｰﾈﾝﾄを展開する

こちらの続きです。
指定した2D要素を、指定した原点位置でｺﾋﾟﾍﾟする - C#ATIA

予告していた、2Dｺﾝﾎﾟｰﾈﾝﾄ(2D構成要素)を展開するﾏｸﾛです。

ｱｸﾃｨﾌﾞなDrawｼｰﾄ全てのﾋﾞｭｰ内(ﾒｲﾝ・背景・ﾛｯｸ・非表示)にある
2Dｺﾝﾎﾟｰﾈﾝﾄが対象です。

'vba sample_Comp2DExplode ver0.0.3
'using-'KCL0.09'
'ｱｩﾃｨﾌﾞなｼｰﾄのﾒｲﾝと背景以外のﾋﾞｭｰにある2Dｺﾝﾎﾟｰﾈﾝﾄを全て展開

Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not KCL.CanExecute("DrawingDocument") Then Exit Sub

    'ｺﾝﾎﾟｰﾈﾝﾄ2Dの存在するﾋﾞｭｰ取得
    Dim ViewLst As Collection: Set ViewLst = GetExistComp2DView()
    If ViewLst.Count < 1 Then
        MsgBox "ｱｸﾃｨﾌﾞなｼｰﾄ内のｱﾝﾛｯｸされたﾋﾞｭｰ内には、" & vbNewLine & _
               "ｺﾝﾎﾟｰﾈﾝﾄ2Dが存在しませんでした", vbInformation
        Exit Sub
    End If
    
    'ｺﾝﾎﾟｰﾈﾝﾄ2D取得
    Dim CompLst As Collection: Set CompLst = GetComp2DList(ViewLst)
    
    'ﾕｰｻﾞｰ選択
    Dim Msg$: Msg = "ｱｸﾃｨﾌﾞなｼｰﾄには" & _
                    CreateMsg(ViewLst, CompLst) & vbNewLine & _
                    "のｺﾝﾎﾟｰﾈﾝﾄ2Dが存在します。　全て展開しますか?"
    If MsgBox(Msg, vbOKCancel + vbInformation) = vbCancel Then Exit Sub
    
    '展開
    Call ExecuteExplode(CompLst)
    
    '終了
    MsgBox "終了"
End Sub

'展開
Private Sub ExecuteExplode(ByVal CompLst As Collection)
    Dim Lst As Collection
    Dim Cmp As DrawingComponent
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    
    CATIA.HSOSynchronized = False
        Sel.Clear
        For Each Lst In CompLst
            For Each Cmp In Lst
                Cmp.Explode
                Sel.Add Cmp
            Next
        Next
        Sel.Delete
    CATIA.HSOSynchronized = True
End Sub

'ﾒｯｾｰｼﾞ作成
Private Function CreateMsg(ByVal ViewLst As Collection, _
                            ByVal CompLst As Collection) As String
    Dim Ary(): ReDim Ary(ViewLst.Count)
    Dim i&
    For i = 1 To ViewLst.Count
        Ary(i) = "ﾋﾞｭｰ '" & ViewLst(i).Name & "' - " & _
                    CStr(CompLst(i).Count) & "個"
    Next
    CreateMsg = Join(Ary, vbNewLine)
End Function

'ｺﾝﾎﾟｰﾈﾝﾄ2D取得
Private Function GetComp2DList(ByVal ViewLst As Collection) As Collection
    Set GetComp2DList = Nothing
    
    Dim Vw As DrawingView
    Dim Lst As Collection: Set Lst = New Collection
    For Each Vw In ViewLst
        Lst.Add DeepCopyCatCollection(Vw.Components, "DrawingComponents")
    Next
    Set GetComp2DList = Lst
End Function

'ｺﾝﾎﾟｰﾈﾝﾄ2Dの存在するﾋﾞｭｰ取得 　ﾒｲﾝ・背景・ﾛｯｸ・非表示除外
Private Function GetExistComp2DView() As Collection
    Set GetExistComp2DView = Nothing
    
    Dim Vws As DrawingViews
    Set Vws = CATIA.ActiveDocument.Sheets.ActiveSheet.Views
    If Vws.Count < 3 Then Exit Function
    
    Dim ViewLst As Collection
    Set ViewLst = DeepCopyCatCollection(Vws, "DrawingViews")
    Call ViewLst.Remove(1) 'ﾒｲﾝ削除
    Call ViewLst.Remove(1) '背景削除
    
    
    Dim Vw As DrawingView
    Dim Lst As Collection: Set Lst = New Collection
    For Each Vw In ViewLst
        If Vw.LockStatus = False And IsShow(Vw) And _
                                Vw.Components.Count > 0 Then
            Lst.Add Vw
        End If
    Next
    Set GetExistComp2DView = Lst
End Function

'表示?
Private Function IsShow(ByVal Oj As AnyObject) As Boolean
    Dim Sel As Selection: Set Sel = CATIA.ActiveDocument.Selection
    Dim Vis As VisPropertySet:
    Set Vis = Sel.VisProperties
    Dim ShowState As CatVisPropertyShow
    
    CATIA.HSOSynchronized = False
        Sel.Clear
        Sel.Add Oj
        Call Vis.GetShow(ShowState)
        Sel.Clear
    CATIA.HSOSynchronized = True
    
    IsShow = IIf(ShowState = catVisPropertyDefined, True, False)
End Function

'ｸﾛｰﾝ
Private Function DeepCopyCatCollection(ByVal CatCol As AnyObject, _
                                        ByVal OjType$) As Collection
    Set DeepCopyCatCollection = Nothing
    
    Dim Col As Variant
    Select Case OjType '面倒･･･
        Case "DrawingViews"
            Dim Vws As DrawingViews: Set Vws = CatCol
            Set Col = Vws
            
        Case "DrawingComponents"
            Dim Cmps As DrawingComponents: Set Cmps = CatCol
            Set Col = Cmps
            
        Case Else
            Set Col = CatCol
    End Select
    
    Dim Lst As Collection: Set Lst = New Collection
    Dim v
    For Each v In Col
        Lst.Add v
    Next
    Set DeepCopyCatCollection = Lst
End Function

これぐらいなら、それ程苦労せずに作成出来るのですが。