他Partとﾘﾝｸした平面の作成4

出来上がりました。
全体的な流れはCATMainﾒｿｯﾄﾞをご覧になれば、把握できるかと思います。

'CreateLinkedPlane - vba
Option Explicit

Type ItemPart
    Item As AnyObject
    Part As Part
End Type

Sub CATMain()
    'ﾌﾟﾛﾀﾞｸﾄﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not IsProductDocument Then
        MsgBox "Please open the CATProduct File!!"
        End
    End If
    
    '点の選択
    Dim SelPoint As ItemPart
    SelPoint = SelectItem(VertexFilter, "Select a Point　/ [Esc]=Cancel")
    
    '線の選択
    Dim SelLine As ItemPart
    SelLine = SelectItem(StraightLineFilter, "Select a line　/ [Esc]=Cancel")
    
    'ﾘﾝｸ元点作成
    Dim Point As ItemPart
    Point = CreateHSExtract(SelPoint)
    
    'ﾘﾝｸ元線作成
    Dim Normal As ItemPart
    Normal = CreateHSExtract(SelLine)
    
    'Partの追加
    Dim NewPart As Part
    Set NewPart = AddNewPart
    
    'ﾘﾝｸﾍﾟｰｽﾄ
    Dim Items(2) As ItemPart
    Items(1) = Point
    Items(2) = Normal
    Dim Point_Normal_References As Collection
    Set Point_Normal_References = CopyPaste_ResultWithLink(Items, NewPart)
    
    '平面作成
    Call CreatePlane(Point_Normal_References(1), Point_Normal_References(2))
    
    '終わり
    MsgBox "Finish"
End Sub

'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
Private Function IsProductDocument() As Boolean
    On Error Resume Next
       Dim temp As ProductDocument
       Set temp = CATIA.ActiveDocument
       IsProductDocument = IIf(Err.Number = 0, True, False)
    On Error GoTo 0
End Function

'平面作成
Private Sub CreatePlane(PointRef As Reference, NormalRef As Reference)
    Dim WorkPart As Part
    Set WorkPart = GetPart(PointRef)
    
    Dim HSFact As HybridShapeFactory
    Set HSFact = WorkPart.HybridShapeFactory
    
    Dim HSPlaneNormal As HybridShapePlaneNormal
    Set HSPlaneNormal = HSFact.AddNewPlaneNormal(NormalRef, PointRef)
    
    Dim HBody As HybridBody
    Set HBody = WorkPart.HybridBodies.Add
    Call HBody.AppendHybridShape(HSPlaneNormal)
    Call WorkPart.UpdateObject(HSPlaneNormal)
End Sub

'ｺﾋﾟﾍﾟ
Private Function CopyPaste_ResultWithLink(Items() As ItemPart, TargetPart As Part) As Collection
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    Dim i As Long
    With Sel
        .Clear
        For i = 1 To UBound(Items)
            Call .Add(Items(i).Item)
        Next
        .Copy
        .Clear
        Call .Add(TargetPart)
        Call .PasteSpecial("CATPrtResult")
        TargetPart.Update
        'ここでﾍﾟｰｽﾄしたｱｲﾃﾑ拾う
        Dim Refs As New Collection
        For i = 1 To .Count2
            Call Refs.Add(.Item2(i).Reference)
        Next
        .Clear
    End With
    Call ItemHide(TargetPart.HybridBodies.Item(1))
    Set CopyPaste_ResultWithLink = Refs
End Function

'Partの追加
Private Function AddNewPart() As Part
    Dim Dammy As Products
    Set Dammy = CATIA.ActiveDocument.Product.Products.AddNewComponent("Part", "")
    
    Dim Docs As Documents
    Set Docs = CATIA.Documents
    
    Set AddNewPart = Docs.Item(Docs.Count).Part
End Function

'抽出
Private Function CreateHSExtract(I_P As ItemPart) As ItemPart
    Dim Ref As Reference
    Set Ref = I_P.Part.CreateReferenceFromBRepName(GetBrepName(I_P.Item.Name), I_P.Item.Parent)
    
    Dim HSExtract As HybridShapeExtract
    Set HSExtract = I_P.Part.HybridShapeFactory.AddNewExtract(Ref)
    With HSExtract
        .PropagationType = 3
        .ComplementaryExtract = False
        .IsFederated = False
    End With
    
    Dim HBody As HybridBody
    Set HBody = I_P.Part.HybridBodies.Add
    HBody.Name = "ExportItem"
    Call ItemHide(HBody)
    
    Call HBody.AppendHybridShape(HSExtract)
    Call I_P.Part.UpdateObject(HSExtract)
    
    Dim ExtI_P As ItemPart
    Set ExtI_P.Item = HSExtract
    Set ExtI_P.Part = I_P.Part
    CreateHSExtract = ExtI_P
End Function

'Partの取得
Private Function GetPart(ByVal OJ As AnyObject) As Part
    Select Case TypeName(OJ.Parent)
        Case "Part"
            Set GetPart = OJ.Parent
        Case "Application"
            Set GetPart = Nothing
        Case Else
            Set GetPart = GetPart(OJ.Parent)
    End Select
End Function

'SelectElement用BrapName取得-thanks coe
Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

'非表示
Private Sub ItemHide(Item As AnyObject)
    Dim Sel As Selection
    Set Sel = CATIA.ActiveDocument.Selection
    With Sel
        .Clear
        Call .Add(Item)
        Call .VisProperties.SetShow(catVisPropertyNoShowAttr)
        .Clear
    End With
    Set Sel = Nothing
End Sub

'選択
Private Function SelectItem(Filter, Msg As String) As ItemPart
    Dim Sel 'As selection
    Set Sel = CATIA.ActiveDocument.Selection
    
    With Sel
        .Clear
        If "Cancel" = .SelectElement2(Filter, Msg, False) Then
            Call MsgBox("Cancellation!")
            End
        End If
        
        Dim I_P As ItemPart
        Set I_P.Item = .Item(1).Value
        Set I_P.Part = GetPart(I_P.Item)
        If I_P.Part Is Nothing Then
            Call MsgBox("Cancellation!")
            End
        End If
        .Clear
    End With
    SelectItem = I_P
    Set Sel = Nothing
End Function

'SelectElement用直線ﾌｨﾙﾀｰ
Private Function StraightLineFilter() As Variant
    Dim Ary(1) As Variant
    Ary(0) = "RectilinearMonoDimFeatEdge"
    Ary(1) = "RectilinearTriDimFeatEdge"
    StraightLineFilter = Ary
End Function

'SelectElement用点ﾌｨﾙﾀｰ
Private Function VertexFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Vertex"
    VertexFilter = Ary
End Function

ｸﾗｽを使用しようかとも思いましたが、ﾌｧｲﾙが分かれるを嫌い、
ﾕｰｻﾞｰ定義型で済ませました。

平面作成の為の点と線は、異なるPartファイルでも対応できるように
したつもりです。
でも、そんなに複雑にﾘﾝｸさせていると、後で困るような気もしますね。
~~StackOverflowのｺｰﾄﾞ用のﾀｸﾞと使い方がわかれば、投稿するんだけどなぁ。~~
初めて投稿してみましたが、やっぱりｺｰﾄﾞ用のﾀｸﾞと使い方が理解できず
イマイチな表示に・・・。Brian Tompsettさんが直してくれたようです。

C#ATIA

↑ﾀｲﾄﾙ詐欺　主にFusion360API　偶にCATIA V5 VBA(絶賛ネタ切れ中)

他Partとﾘﾝｸした平面の作成4