1つのPartからBody毎にしたProductを作り出す2

予め、お伝えしておきます。
KCLを更新しました。
非常に個人的なCATVBA用ﾗｲﾌﾞﾗﾘ - C#ATIA

ﾘﾝｸの画面やｶﾀﾛｸﾞ等を開いた状態でﾏｸﾛを実行すると、
ｴﾗｰで止まってしまうのを防ぎたかったので。

こちらの続きです。
1つのPartからBody毎にしたProductを作り出す - C#ATIA

前回のｺﾒﾝﾄに書いたｿｰｽｺｰﾄﾞは少し参考にさせてもらいました。
あちらのものより処理は速いかな？　とは思います。

'vba sample_Part2Product_ver0.0.2  using-'ver0.0.11'
'PartからProduct化します
'ﾎﾞﾃﾞｨ･形状ｾｯﾄ･時系列形状ｾｯﾄで表示されているもののみ
'(ｽｹｯﾁは対象外)

Option Explicit

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    'Part
    Dim BaseDoc As PartDocument: Set BaseDoc = CATIA.ActiveDocument
    
    Dim BasePath As Variant: BasePath = Array(BaseDoc.FullName)
    
    Dim Pt As Part: Set Pt = BaseDoc.Part
    
    Dim LeafItems As Collection: Set LeafItems = Get_LeafItemLst(Pt.Bodies)
    
    Dim Msg As String
    If LeafItems Is Nothing Then
        Msg = "ｺﾋﾟｰ可能な要素がありません!"
        MsgBox Msg, vbOKOnly + vbExclamation
        Exit Sub
    End If
    
    '確認
    Msg = LeafItems.Count & "個のｺﾋﾟｰ可能な要素があります。" & vbNewLine & _
          "ﾍﾟｰｽﾄするﾀｲﾌﾟを指定してください" & vbNewLine & vbNewLine & _
          "はい : ﾘﾝｸの結果として(As Result With Link)" & vbNewLine & _
          "いいえ : 結果として(As Result)" & vbNewLine & _
          "キャンセル : マクロ中止"
    Dim PasteType As String
    Select Case MsgBox(Msg, vbQuestion + vbYesNoCancel)
        Case vbYes
            PasteType = "CATPrtResult"
        Case vbNo
            PasteType = "CATPrtResultWithOutLink"
        Case Else
            Exit Sub
    End Select
    
    KCL.SW_Start

    'Assy
    Dim TopDoc As ProductDocument: Set TopDoc = CATIA.Documents.Add("Product")
    
    Call ToProduct(TopDoc, LeafItems, PasteType)
    
    TopDoc.Product.Update
    
    Debug.Print "Time:" & KCL.SW_GetTime & "s"
    MsgBox "Done"
End Sub

'Productにﾍﾟｰｽﾄ
Private Sub ToProduct(ByVal TopDoc As ProductDocument, _
                      ByVal LeafItems As Collection, _
                      ByVal PasteType As String)
    Dim TopSel As Selection
    Set TopSel = TopDoc.Selection
    
    Dim BaseSel As Selection
    Set BaseSel = KCL.GetParent_Of_T(LeafItems(1), "PartDocument").Selection
    
    Dim Prods As Products
    Set Prods = TopDoc.Product.Products
    
    Dim Itm As AnyObject
    Dim TgtDoc As PartDocument
    Dim ProdsNameDic As Object: Set ProdsNameDic = KCL.InitDic()
    
    CATIA.HSOSynchronized = False
    
    For Each Itm In LeafItems
        If ProdsNameDic.Exists(Itm.Name) Then
            Set TgtDoc = ProdsNameDic.Item(Itm.Name)
        Else
            Set TgtDoc = Init_Part(Prods, Itm.Name)
            ProdsNameDic.Add Itm.Name, TgtDoc
        End If
        
        Call Preparing_Copy(BaseSel, Itm)
        With BaseSel
            .Copy
            .Clear
        End With
        
        With TopSel
            .Clear
            .Add TgtDoc.Part
            .PasteSpecial PasteType
        End With
    Next
    BaseSel.Clear
    TopSel.Clear
    CATIA.HSOSynchronized = True
End Sub

'ｺﾋﾟｰ要素を選択状態にする
Private Sub Preparing_Copy(ByVal Sel As Selection, ByVal Itm As AnyObject)
    Sel.Clear
    
    'Body
    If TypeName(Itm) = "Body" Then
        Sel.Add Itm
        Exit Sub
    End If
    
    'HybridBody
    Dim ShpsLst As Collection: Set ShpsLst = New Collection
    ShpsLst.Add Itm.HybridShapes
    
    Select Case TypeName(Itm)
        Case "HybridBody"
            Set ShpsLst = Get_All_HbShapes(Itm, ShpsLst)
        Case "OrderedGeometricalSet"
            Set ShpsLst = Get_All_OdrGeoSetShapes(Itm, ShpsLst)
    End Select
    
    Dim Shps As HybridShapes, Shp As HybridShape
    For Each Shps In ShpsLst
        For Each Shp In Shps
            Sel.Add Shp
        Next
    Next
End Sub

'指定時系列形状ｾｯﾄ以下の全てHybridShapesを取得
'再帰　かなり効率悪いかも
Private Function Get_All_OdrGeoSetShapes(ByVal OdrGeoSet As OrderedGeometricalSet, _
                                         ByVal Lst As Collection) As Collection
    Dim Child As OrderedGeometricalSet
    For Each Child In OdrGeoSet.OrderedGeometricalSets
        Lst.Add Child.HybridShapes
        If Child.OrderedGeometricalSets.Count > 0 Then
            Set Lst = Get_All_OdrGeoSetShapes(Child, Lst)
        End If
    Next
    Set Get_All_OdrGeoSetShapes = Lst
End Function

'指定形状ｾｯﾄ以下の全てHybridShapesを取得
'再帰　かなり効率悪いかも
Private Function Get_All_HbShapes(ByVal Hbdy As HybridBody, _
                                  ByVal Lst As Collection) As Collection
    Dim Child As HybridBody
    For Each Child In Hbdy.hybridBodies
        Lst.Add Child.HybridShapes
        If Child.hybridBodies.Count > 0 Then
            Set Lst = Get_All_HbShapes(Child, Lst)
        End If
    Next
    Set Get_All_HbShapes = Lst
End Function

'ﾙｰﾄで、空ではなく表示されているﾎﾞﾃﾞｨ・形状ｾｯﾄ取得
Private Function Get_LeafItemLst(ByVal Pt As Part) As Collection
    Set Get_LeafItemLst = Nothing
    
    Dim Sel As Selection: Set Sel = Pt.Parent.Selection
    Dim TmpLst As Collection: Set TmpLst = New Collection
    Dim I As Long

    Dim Filter As String
    Filter = "(CATPrtSearch.BodyFeature.Visibility=Shown " & _
            "+ CATPrtSearch.OpenBodyFeature.Visibility=Shown" & _
            "+ CATPrtSearch.MMOrderedGeometricalSet.Visibility=Shown),sel"
    
    CATIA.HSOSynchronized = False
    
    With Sel
        .Clear
        .Add Pt
        .Search Filter
        For I = 1 To .Count2
            TmpLst.Add .Item(I).Value
        Next
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    If TmpLst.Count < 1 Then Exit Function
    
    Dim LeafHBdys As Object: Set LeafHBdys = KCL.InitDic()
    Dim Hbdy As AnyObject 'HybridBody & OrderedGeometricalSets
    For Each Hbdy In Pt.hybridBodies
        LeafHBdys.Add Hbdy, 0
    Next
    For Each Hbdy In Pt.OrderedGeometricalSets
        LeafHBdys.Add Hbdy, 0
    Next
    
    
    Dim Itm As AnyObject
    Dim Lst As Collection: Set Lst = New Collection
    For Each Itm In TmpLst
        Select Case TypeName(Itm)
            Case "Body"
                If Is_LeafBody(Itm) Then Lst.Add Itm
            Case Else 'HybridBody & OrderedGeometricalSets
                If Is_LeafHybridBody(Itm, LeafHBdys) Then Lst.Add Itm
        End Select
    Next
    If Lst.Count < 1 Then Exit Function
    
    Set Get_LeafItemLst = Lst
End Function

'ﾙｰﾄのﾎﾞﾃﾞｨで中身が有るか?
Private Function Is_LeafBody(ByVal Bdy As Body) As Boolean
    Is_LeafBody = Bdy.InBooleanOperation = False And Bdy.Shapes.Count > 0
End Function

'ﾙｰﾄの形状ｾｯﾄで中身が有り可視か?As HybridBody
'prm:Hbdy - HybridBody & OrderedGeometricalSets
Private Function Is_LeafHybridBody(ByVal Hbdy As AnyObject, _
                                   ByVal Dic As Object) As Boolean
    Is_LeafHybridBody = False
    If Not Dic.Exists(Hbdy) Then Exit Function
    
    CATIA.HSOSynchronized = False
    
    Dim Sel As Selection
    Set Sel = KCL.GetParent_Of_T(Hbdy, "PartDocument").Selection
    
    Dim Cnt As Long
    
    With Sel
        .Clear
        .Add Hbdy
        .Search "Visibility=Shown,sel"
        Cnt = .Count2
        .Clear
    End With
    
    CATIA.HSOSynchronized = True
    
    If Cnt > 1 Then Is_LeafHybridBody = True
End Function

'Part新作
Private Function Init_Part(ByVal Prods As Variant, _
                           ByVal PtNum As String) As PartDocument
    Dim Prod As Product
    On Error Resume Next
        Set Prod = Prods.AddNewComponent("Part", PtNum)
    On Error GoTo 0
    Set Init_Part = Prods.Item(Prods.Count).ReferenceProduct.Parent
End Function