Bodyの穴っぽい部分に点を作成

業務上欲しくなったので、久々にCATIAのﾏｸﾛを作成しました。

穴あけ加工をCAMで作る際、Space-eでは穴位置となる点が
欲しかったので、こちらのﾏｸﾛをかなり前に作成しました。
指定した平面から、穴の中心点を作成する1 - C#ATIA

本来であれば、3Dの形状から穴位置と深さを取得した上で
ﾊﾞｧｰっと作りたいのが本音です。面倒なので・・・。

Space-eにもそれっぽい機能がある事を薄々は知っていたの
ですが、ｻﾎﾟｰﾄさんに相談し試したものの、打率が悪く
処理もｲﾏｲﾁ(ﾀﾞﾒならﾀﾞﾒとさっさと返してきて欲しい)
最終的には、出来上がる工程がこちらの運用とちょっと
異なる為、断念しました。

PowerMillの穴あけは、3Dの形状から穴位置と深さを取得
出来るのですが、こちらもちょっと馴染めず諦め、
Space-eで利用しやすいようCATIA側で何とかしてみようかな？
と行き着きました。（結論から書くと点を作成するだけです）

金型をﾓﾃﾞﾘﾝｸﾞする際、加工することを想定し(邪魔になるので)
穴はﾓﾃﾞﾘﾝｸﾞしない会社を知っているのですが、うちもそれに
近い状況です。
ｴｼﾞｪｸﾀﾋﾟﾝの穴はﾓﾃﾞﾙ内に無いのですが、裏からの逃がし穴は
ﾓﾃﾞﾘﾝｸﾞして有ります。
f:id:kandennti:20170929185811p:plain
緑色が製品側で、黄色が逃がし穴です。
(穴の先端が平らなのは、穴ｺﾏﾝﾄﾞじゃないからです。･･･僕が
ﾓﾃﾞﾙを作っているわけじゃないので。)

金型の裏面を指定する事で、
穴の入口、穴深さの位置、表まで貫通しきった位置
の3ヶ所の穴中心位置に点を作成します。

'vba CreateCenterPoint_ver0.0.2  using-'KCL0.0.10'
'個人的に欲しかったもの

Option Explicit

Sub CATMain()

    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute("PartDocument") Then Exit Sub
    
    '面選択
    Dim Msg$
    Msg = "穴位置となる面を選択して下さい : ESCｷｰ 終了"
    Dim TgtFaceElm As SelectedElement
    Set TgtFaceElm = KCL.SelectElement(Msg, "PlanarFace")
    If KCL.IsNothing(TgtFaceElm) Then Exit Sub
    
    Dim TgtFace As PlanarFace
    Set TgtFace = TgtFaceElm.Value
    
    'ﾎﾞﾃﾞｨ取得
    Dim TgtBody As Body
    Set TgtBody = KCL.GetParent_Of_T(TgtFace, "Body")
    If KCL.IsNothing(TgtFaceElm) Then
        MsgBox "ﾎﾞﾃﾞｨの面を選択する必要が有ります"
        Exit Sub
    End If
    
    'ﾓﾛﾓﾛ
    Dim Pt As Part
    Set Pt = KCL.GetParent_Of_T(TgtFace, "Part")
    
    Dim Fact As HybridShapeFactory
    Set Fact = Pt.HybridShapeFactory
    
    Dim Sel As Selection
    Set Sel = Pt.Parent.Selection
    
    Dim Dustbox As Collection '削除用
    Set Dustbox = New Collection
    
    '押し出し方向
    Dim Dir As HybridShapeDirection
    Set Dir = GetDirection(Pt, Fact, False) 'True)
    Dustbox.Add Dir
    
    '形状ｾｯﾄ
    Dim HBdyBase As HybridBody
    Set HBdyBase = InitHBdy(Pt, "HolesCenter")
    
    '中心取得
    Dim Cnts As Collection
    Set Cnts = GetCenter(Pt, Fact, Sel, TgtFaceElm.Value, HBdyBase)
    If KCL.IsNothing(Cnts) Then
        MsgBox "穴の中心は見つかりませんでした"
        Dustbox.Add HBdyBase
        GoTo SubEnd
    End If
    Dustbox.Add Cnts
    'Call DumpGeo(HBdyBase, Cnts) 'debug
    
    '直線
    Dim LinRefs As Collection
    Set LinRefs = GetLineRefs(Pt, Fact, Dir, Cnts, 10000#)
    Dustbox.Add LinRefs
    'Call DumpGeo(HBdyBase, LinRefs) 'debug
    
    '交差
    Dim IntRefs As Collection
    Set IntRefs = GetIntersectRefs(Pt, Fact, TgtBody, LinRefs)
    Dustbox.Add IntRefs
    'Call DumpGeo(HBdyBase, IntRefs) 'debug
    
    '交差ﾁｪｯｸ
    If Not IsInValue(IntRefs) Then
        MsgBox "穴の中心は見つかりませんでした"
        Dustbox.Add HBdyBase
        GoTo SubEnd
    End If
    
    '直線の終点
    Dim FarRefs As Collection
    Set FarRefs = GetPntFarRefs(Pt, Fact, LinRefs)
    Dustbox.Add FarRefs
    'Call DumpGeo(HBdyBase, FarRefs) 'debug
    
    '近傍
    Dim Nears As Collection
    Set Nears = GetNear(Pt, Fact, IntRefs, Cnts)
    'Call DumpGeo(HBdyBase, Nears) 'debug
    
    '遠方
    Dim Fars As Collection
    Set Fars = GetNear(Pt, Fact, IntRefs, FarRefs)
    'Call DumpGeo(HBdyBase, Fars) 'debug
    
    '作成
    Call ToHybridBody(HBdyBase, Pt, Fact, IntRefs, Cnts, Nears, Fars)
    Pt.UpdateObject HBdyBase
    
SubEnd:
    'ｺﾞﾐ処理
    Call Disposal(Dustbox, Fact, Sel)
    
    MsgBox "Done"
End Sub

'全てNothingﾁｪｯｸ
Private Function IsInValue(ByVal Lst As Collection) As Boolean
    IsInValue = True
    Dim v As Variant
    For Each v In Lst
        If Not (v Is Nothing) Then Exit Function
    Next
    IsInValue = False
End Function

'ｺﾞﾐ処理
Private Sub Disposal(ByRef Lst, _
                     ByVal Fact As HybridShapeFactory, _
                     ByVal Sel As Selection)
    On Error Resume Next
        Dim v1, v2
        For Each v1 In Lst
            Select Case TypeName(v1)
                Case "Collection"
                    For Each v2 In v1
                        Fact.DeleteObjectForDatum v2
                    Next
                Case "HybridBody"
                    Call DelItem(Sel, v1)
                Case Else
                    Fact.DeleteObjectForDatum v1
            End Select
        Next
    On Error GoTo 0
End Sub

'削除
Private Sub DelItem(ByVal Sel As Selection, ByVal itm As Variant)
    Dim i&
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add itm
        .Delete
    End With
    CATIA.HSOSynchronized = True
End Sub

'階層作って形状ｾｯﾄに代入
Private Sub ToHybridBody(ByVal Hbdy As HybridBody, _
                         ByVal Pt As Part, _
                         ByVal Fact As HybridShapeFactory, _
                         ByVal IntRefs As Collection, _
                         ByVal Btms As Collection, _
                         ByVal Mids As Collection, _
                         ByVal Tops As Collection)
    Dim TopHbdy As HybridBody: Set TopHbdy = InitHBdy(Hbdy, "Top")
    Dim MidHbdy As HybridBody: Set MidHbdy = InitHBdy(Hbdy, "Mid")
    Dim BtmHbdy As HybridBody: Set BtmHbdy = InitHBdy(Hbdy, "Btm")
    Dim i&
    For i = 1 To IntRefs.Count
        If KCL.IsNothing(IntRefs.Item(i)) Then GoTo Continue_For
        TopHbdy.AppendHybridShape Tops.Item(i)
        MidHbdy.AppendHybridShape Mids.Item(i)
        BtmHbdy.AppendHybridShape Fact.AddNewPointDatum(Btms.Item(i))
Continue_For:
    Next
End Sub

'形状ｾｯﾄ
Private Function InitHBdy(ByVal Parent, ByVal Name$)
    Dim Hb As HybridBody
    Set Hb = Parent.HybridBodies.Add()
    Hb.Name = Name
    Set InitHBdy = Hb
End Function

'近傍
Private Function GetNear(ByVal Pt As Part, _
                         ByVal Fact As HybridShapeFactory, _
                         ByVal IntRefs As Collection, _
                         ByVal PntRefs As Collection) As Collection
    Dim i&
    Dim Near As HybridShapeNear, Ref As Reference, Pnt As AnyObject
    Dim Nears As Collection: Set Nears = New Collection
    For i = 1 To IntRefs.Count
        If KCL.IsNothing(IntRefs.Item(i)) Then
            Nears.Add Nothing
            GoTo Continue_For
        End If
        Set Near = Fact.AddNewNear(IntRefs.Item(i), PntRefs.Item(i))
        Pt.UpdateObject Near
        Set Ref = Pt.CreateReferenceFromGeometry(Near)
        Set Pnt = Fact.AddNewPointDatum(Ref)
        Nears.Add Pnt
Continue_For:
    Next

    Set GetNear = Nears
End Function

'AddNewFarが無い為対策用の点
Private Function GetPntFarRefs(ByVal Pt As Part, _
                               ByVal Fact As HybridShapeFactory, _
                               ByVal LinRefs As Collection) As Collection
    Dim Pnt As HybridShapePointOnCurve, Ref As Reference
    Dim FarRefs As Collection: Set FarRefs = New Collection
    For Each Ref In LinRefs
        Set Pnt = Fact.AddNewPointOnCurveFromPercent(Ref, 1#, False)
        Pt.UpdateObject Pnt
        FarRefs.Add Pt.CreateReferenceFromGeometry(Pnt)
    Next
    
    Set GetPntFarRefs = FarRefs
End Function

'交差
Private Function GetIntersectRefs(ByVal Pt As Part, _
                                  ByVal Fact As HybridShapeFactory, _
                                  ByVal Bdy As Body, _
                                  ByVal LinRefs As Collection) As Collection
    Dim BdyRef As Reference
    Set BdyRef = Pt.CreateReferenceFromGeometry(Bdy)
    
    On Error Resume Next
    
    Dim LinRef As AnyObject, Intsect As HybridShapeIntersection
    Dim IntRefs As Collection: Set IntRefs = New Collection
    For Each LinRef In LinRefs
        Set Intsect = Fact.AddNewIntersection(BdyRef, LinRef)
        Intsect.PointType = 0
        Pt.UpdateObject Intsect
        If Err.Number = 0 Then
            IntRefs.Add Pt.CreateReferenceFromGeometry(Intsect)
        Else
            IntRefs.Add Nothing
            'Fact.DeleteObjectForDatum Intsect'これNG
        End If
    Next
    
    On Error GoTo 0
    
    Set GetIntersectRefs = IntRefs
End Function

'直線
Private Function GetLineRefs(ByVal Pt As Part, _
                             ByVal Fact As HybridShapeFactory, _
                             ByVal Dir As HybridShapeDirection, _
                             ByVal Pnts As Collection, _
                             ByVal Leng As Double) As Collection
    Dim Pnt As AnyObject, PntRef As Reference
    Dim LineRefs As Collection: Set LineRefs = New Collection
    Dim Lin As HybridShapeLinePtDir, LinRef As Reference
    For Each Pnt In Pnts
        Set PntRef = Pt.CreateReferenceFromGeometry(Pnt)
        Set Lin = Fact.AddNewLinePtDir(PntRef, Dir, 0#, Leng, False)
        Pt.UpdateObject Lin
        LineRefs.Add Pt.CreateReferenceFromGeometry(Lin)
    Next
    Set GetLineRefs = LineRefs
End Function

'押し出し方向
'SelectFG : True-ﾕｰｻﾞｰ指定座標系　False-PartのXYPlane
Private Function GetDirection(ByVal Pt As Part, _
                              ByVal Fact As HybridShapeFactory, _
                              ByVal SelectFG As Boolean) As HybridShapeDirection
    Set GetDirection = Nothing
    Dim Ref As Reference
    If SelectFG Then
        Dim Msg$
        Msg = "ﾁｪｯｸ方向をZ軸とする座標系を選択して下さい : ESCｷｰ 終了"
        Dim Axis As AxisSystem
        Set Axis = KCL.SelectItem(Msg, "AxisSystem")
        If KCL.IsNothing(Axis) Then Exit Function
        Set Ref = Axis.ZAxisDirection
    Else
        Set Ref = Pt.CreateReferenceFromGeometry(Pt.OriginElements.PlaneXY)
    End If
    Set GetDirection = Fact.AddNewDirection(Ref)
End Function

'中心点
Private Function GetCenter(ByVal Pt As Part, _
                           ByVal Fact As HybridShapeFactory, _
                           ByVal Sel As Selection, _
                           ByVal FaceRef, _
                           ByVal Hbdy As HybridBody) As Collection
    Set GetCenter = Nothing
    
    Dim Ext As HybridShapeExtract
    Set Ext = Fact.AddNewExtract(FaceRef)
    With Ext
        .PropagationType = 3
        .ComplementaryExtract = False
        .IsFederated = False
    End With
    Call Pt.UpdateObject(Ext)
    
    Hbdy.AppendHybridShape Ext
    
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add Ext
        .Search "Topology.CGMEdge,sel"
    End With
    
    Dim i&, Edges As Collection
    Set Edges = New Collection
    For i = 1 To Sel.Count
        Edges.Add Sel.Item(i)
    Next
    Sel.Clear
    CATIA.HSOSynchronized = True
    
    If Edges.Count < 1 Then GoTo Exit_Func
    
    On Error Resume Next
    
    Dim EgElm As AnyObject, Cnt As AnyObject, Pnt As AnyObject, Ref As Reference
    Dim Pnts As Collection: Set Pnts = New Collection
    For Each EgElm In Edges
        Set Cnt = Fact.AddNewPointCenter(EgElm.Reference)
        Pt.UpdateObject Cnt
        If KCL.IsNothing(Cnt) Then GoTo Continue_ForEach
        Set Ref = Pt.CreateReferenceFromGeometry(Cnt)
        Set Pnt = Fact.AddNewPointDatum(Ref)
        Pt.UpdateObject Pnt
        Fact.DeleteObjectForDatum Cnt
        If KCL.IsNothing(Pnt) Then GoTo Continue_ForEach
        If Not Lst_Contains(Pnts, Pnt) Then Pnts.Add Pnt
Continue_ForEach:
    Next
        
    On Error GoTo 0
    
    If Pnts.Count < 1 Then GoTo Exit_Func
    Set GetCenter = Pnts
    
Exit_Func:
    Fact.DeleteObjectForDatum Ext
End Function

'重複ﾁｪｯｸ
Private Function Lst_Contains(ByVal Lst As Collection, _
                              ByVal Value As AnyObject) As Boolean
    Lst_Contains = True
    Dim itm As AnyObject
    For Each itm In Lst
        If itm Is Value Then Exit Function
    Next
    Lst_Contains = False
End Function

'ﾃﾞﾊﾞｯｸﾞ用
Private Sub DumpGeo(ByVal Hbdy As HybridBody, ByVal Lst As Collection)
    Dim Oj As AnyObject
    If TypeName(Lst.Item(1)) = "Reference" Then
        Dim Fact As HybridShapeFactory
        Set Fact = KCL.GetParent_Of_T(Hbdy, "Part").HybridShapeFactory
        For Each Oj In Lst
            If Not KCL.IsNothing(Oj) Then
                Hbdy.AppendHybridShape Fact.GSMGetObjectFromReference(Oj)
            End If
        Next
    Else
        For Each Oj In Lst
            If Not KCL.IsNothing(Oj) Then
                Hbdy.AppendHybridShape Oj
            End If
        Next
    End If
End Sub

うっかりしていましたが、貫通穴には点が作成されません。

こんな感じです。

実は、交差を処理している辺りに一時的に作成したものが
上手く削除しきれていない為、CATDUAのｸﾘｰﾝ実行すると
幾つもｺﾞﾐを処理されます。(ｲﾏｲﾁです)

他人には役立つとは思えませんが。