C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA

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

・履歴有りのPartファイルでも、それなりの処理を行います。

・ボディ・形状セット・時系列形状セットでTreeのルート?に
 ぶら下がって、表示されているもののみが対象です。(スケッチは対象外)

・元データの形状セット・時系列形状セットが階層状になっている
 ものは、全て同一レベルでペーストされます。

・ボディ等の名前が同一場合、同一のPartに取り込まれます。

・ボディ内に入っている形状セット等、素直じゃない階層は
 見捨ててます。

・ハイブリッドデザインは、未テストです。

・ペーストする際は "リンクの結果として" "結果として" が選べます。

"リンクの結果として" が可能になるようにしたかったので、
こだわりました。 支給ファイルの差し替えが出来るような気がしたので。
(リンクを切るのは何時でも出来ますし)


手元に大き目のデータが無かった為、GrabCADからお借りしました。
GrabCAD - CAD library
この方、日本人なんですよね。

お借りしたデータで試しました。

結局、保存はしてません・・・。ファイル名まで手動でやろうとすると手間だよなぁ。