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




Sub CATMain()
    Dim HBdy As HybridBody
    Set HBdy = SelectItem("Select a HybridBody : ESC = Cancel", Array("HybridBody"))
    If HBdy Is Nothing Then Exit Sub
    Dim Pt As Part: Set Pt = GetParent_Of_T(HBdy, "Part")
    If Pt Is Nothing Then Exit Sub
    'Point Refs
    Dim PntRefLst As Collection: Set PntRefLst = GetPntRefs(HBdy, Pt)
    If PntRefLst Is Nothing Then Exit Sub
    Dim Pln As Plane
    Set Pln = SelectItem("Select a Sketch_Support_Plane : ESC = Cancel", Array("Plane"))
    If Pln Is Nothing Then Exit Sub
    'Part Check
    Dim TmpPt As Part: Set TmpPt = GetParent_Of_T(Pln, "Part")
    If Not (Pt Is TmpPt) Then
        MsgBox "Please choose the Plane of the same Part!"
        Exit Sub
    End If
    Dim NewHbdy As HybridBody: Set NewHbdy = Pt.HybridBodies.Add()
    Dim Skt As Sketch: Set Skt = InitSketch(NewHbdy, Pt.CreateReferenceFromObject(Pln))
    Call ProjectionPnts(Skt, PntRefLst)
    Pt.UpdateObject Skt
    MsgBox "Done"
End Sub

Private Sub ProjectionPnts(ByVal Skt As Sketch, ByVal PntRefLst As Collection)
    Dim Fact2D As Factory2D
    Dim Ref As Reference
    Dim Geos As GeometricElements
    On Error Resume Next
        Set Fact2D = Skt.OpenEdition()
        For Each Ref In PntRefLst
            Set Geos = Fact2D.CreateProjections(Ref)
            Geos.Item(1).Name = Ref.DisplayName
    On Error GoTo 0
End Sub

Private Function InitSketch(ByVal HBdy As HybridBody, ByVal SktSptRef As Reference) As Sketch
    Set InitSketch = HBdy.HybridSketches.Add(SktSptRef)
End Function

Private Function GetPntRefs(ByVal HBdy As HybridBody, ByVal Pt As Part) As Collection
    Set GetPntRefs = Nothing
    Dim HShps As HybridShapes: Set HShps = HBdy.HybridShapes
    If HShps.Count < 1 Then Exit Function
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    Dim PntRefLst As Collection: Set PntRefLst = New Collection
    Dim HShp As HybridShape
    For Each HShp In HShps
        If Fact.GetGeometricalFeatureType(HShp) = 1 Then
            PntRefLst.Add Pt.CreateReferenceFromObject(HShp)
        End If
    If PntRefLst.Count < 1 Then Exit Function
    Set GetPntRefs = PntRefLst
End Function

''' @param:Msg-メッセージ
''' @param:Filter-array(string),string 選択フィルター(指定無し時AnyObject)
''' @return:AnyObject
Private Function SelectItem(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As AnyObject
    Dim SE As SelectedElement
    Set SE = SelectElement(Msg, Filter)
    If IsNothing(SE) Then
        Set SelectItem = SE
        Set SelectItem = SE.Value
    End If
End Function

''' @param:Msg-メッセージ
''' @param:Filter-array(string),string 選択フィルター(指定無し時AnyObject)
''' @return:SelectedElement
Private Function SelectElement(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As SelectedElement
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SelectElement = Sel.Item(1)
End Function

'T型のParent取得 Nameでのチェックも必要
''' @param:AOj-AnyObject
''' @param:T-String
''' @return:AnyObject
Private Function GetParent_Of_T(ByVal AOj As AnyObject, ByVal t$) As AnyObject
    If TypeName(AOj) = TypeName(AOj.Parent) And _
       AOj.Name = AOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AOj) = t Then
        Set GetParent_Of_T = AOj
        Set GetParent_Of_T = GetParent_Of_T(AOj.Parent, t)
    End If
End Function

リンク元の名前に取得したい ってことだろうと