↑タイトル詐欺 主にCATIA V5 の VBA(最近はPMillマクロとFusion360APIが多い)


他Partとリンクした平面の作成3 - C#ATIA


'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 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)
    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
        For i = 1 To UBound(Items)
            Call .Add(Items(i).Item)
        Call .Add(TargetPart)
        Call .PasteSpecial("CATPrtResult")
        Dim Refs As New Collection
        For i = 1 To .Count2
            Call Refs.Add(.Item2(i).Reference)
    End With
    Call ItemHide(TargetPart.HybridBodies.Item(1))
    Set CopyPaste_ResultWithLink = Refs
End Function

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

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
        Call .Add(Item)
        Call .VisProperties.SetShow(catVisPropertyNoShowAttr)
    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
        If "Cancel" = .SelectElement2(Filter, Msg, False) Then
            Call MsgBox("Cancellation!")
        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 If
    End With
    SelectItem = I_P
    Set Sel = Nothing
End Function

Private Function StraightLineFilter() As Variant
    Dim Ary(1) As Variant
    Ary(0) = "RectilinearMonoDimFeatEdge"
    Ary(1) = "RectilinearTriDimFeatEdge"
    StraightLineFilter = Ary
End Function

Private Function VertexFilter() As Variant
    Dim Ary(0) As Variant
    Ary(0) = "Vertex"
    VertexFilter = Ary
End Function


イマイチな表示に・・・。Brian Tompsettさんが直してくれたようです。