C#ATIA

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

ｸﾘｯｸした面に3Dな矢印と注記を作る

CATIA_V5 VBA KCL

こちらの続きです。
3Dな注記の位置を制御出来ているっぽい(条件付き) - C#ATIA

やっと完成しました。
注記位置については前回通り、条件付となりますが結構満足してます。

'vba sample_CreateArrow_ver0.0.3  using-'ver0.0.10'
'ｸﾘｯｸした面に矢印を作成-注記/自動測定付き

Option Explicit

'*** 設定 ***
Private Const ArwBodyLeng = 20#     '矢印全体の長さ
Private Const ArwLeng = 5#          '矢印先端長さ
Private Const ArwAng = 30#          '矢印先端角度
Private Const TxtHeader = "t="      '注記ﾍｯﾀﾞ
'************

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("PartDocument", "ProductDocument")) Then Exit Sub
    
    'ﾕｰｻﾞｰ選択
    Dim Elm As Variant 'SelectedElement
    Set Elm = KCL.SelectElement("面を選択", "Face")
    If KCL.IsNothing(Elm) Then Exit Sub
    
    'ｸﾘｯｸ座標取得
    Dim Pos(2) As Variant 'Double
    Call Elm.GetCoordinates(Pos)
    
    '各必要なもの取得
    Dim Pt As Part
    Set Pt = Elm.Document.Part
    
    Dim Fact As HybridShapeFactory
    Set Fact = Pt.HybridShapeFactory
    
    Dim DelList As Collection
    Set DelList = New Collection
    
    '選択面Ref
    Dim SurfRef As Reference
    Set SurfRef = Elm.Reference
    
    'ｸﾘｯｸ位置の点
    Dim PntRef As Reference
    Set PntRef = CreatePntRef(Pt, Fact, Pos)
    Call DelList.Add(PntRef)
    
    '向き確認用
    Dim Rev As Boolean: Rev = True
    Dim Msg As String: Msg = "向きを逆転しますか?"
    Dim HBdy As HybridBody
    
    Do
        '法線
        Dim LinRef As Reference
        Set LinRef = CreateNormalRef(Pt, Fact, SurfRef, PntRef, 0#, ArwBodyLeng, Rev)
        Call DelList.Add(LinRef)
        
        '線上の点
        Dim PntOnRef As Reference
        Set PntOnRef = CreatePntOnCrvRef(Pt, Fact, LinRef, ArwLeng, Rev)
        Call DelList.Add(PntOnRef)
        
        '平面
        Dim PlnRef As Reference
        Set PlnRef = CreatePlnRef(Pt, Fact, LinRef, PntRef)
        Call DelList.Add(PlnRef)
    
        '円弧
        Dim Crl As HybridShapeCircleCtrRad
        Set Crl = CreateCrl(Pt, Fact, PntOnRef, PlnRef, ArwAng, ArwLeng)
        Call DelList.Add(Crl)
        
        '円弧端点
        Dim SrtRef As Reference
        Set SrtRef = CreateEndPntRef(Pt, Fact, Crl, True)
        Call DelList.Add(SrtRef)
    
        Dim EndRef As Reference
        Set EndRef = CreateEndPntRef(Pt, Fact, Crl, False)
        Call DelList.Add(EndRef)
        
        '折れ線
        Dim PlyRef As Reference
        Set PlyRef = CreatePlyRef(Pt, Fact, SrtRef, PntRef, EndRef)
        Call DelList.Add(PlyRef)
        
        '接合
        Dim JoinRef As Reference
        Set JoinRef = CreateJoinRef(Pt, Fact, LinRef, PlyRef)
        Call DelList.Add(JoinRef)
        
        'ﾃﾞｰﾀﾑ化
        Dim Dtm As HybridShape
        Set Dtm = ToDatum(Pt, Fact, JoinRef)
        
        '形状ｾｯﾄ作成
        If KCL.IsNothing(HBdy) Then
            Set HBdy = Pt.HybridBodies.Add()
        End If
        Call HBdy.AppendHybridShape(Dtm)
        
        '向き確認
        If MsgBox(Msg, vbYesNo) = vbYes Then
            Call Fact.DeleteObjectForDatum(Dtm)
            Rev = IIf(Rev, False, True)
        Else
            Exit Do
        End If
    Loop
    
    '厚み取得
    Dim Thick As Double
    Thick = TryGetThickness(Pt, Fact, SurfRef, PntRef, Rev)
    
    'ﾕｰｻﾞｰ入力
    Msg = "厚みを入力してください" & vbNewLine & _
          "※注記には [ " & TxtHeader & _
          " ] が、追記されます" & vbNewLine & _
          "(空欄 又は Cancel で 中止)"
    Dim AnnoTxt As String: AnnoTxt = InputTxt(Msg, Thick)
    
    '入力値判断
    If Not AnnoTxt = vbNullString Then
        '注記作成
        Call CreateAnnotation(Pt, Fact, Dtm, Rev, TxtHeader & AnnoTxt)
        
        'ﾋﾞｭｰ非表示
        Call HideTPSView
    Else
        '中止時矢印削除
        Call RemoveItem(HBdy)
    End If
    
    'ｺﾞﾐ掃除
    Dim Ref As Reference
    For Each Ref In DelList
        Call Fact.DeleteObjectForDatum(Ref)
    Next
    
    MsgBox "Done"
End Sub

'*** 注記関連 ***
'作業中止用
Private Sub RemoveItem(ByVal Itm As AnyObject)
    With CATIA.ActiveDocument.Selection
        .Clear
        .Add Itm
        .Delete
    End With
End Sub

'ﾕｰｻﾞｰ入力
Private Function InputTxt( _
                    ByVal Msg As String, _
                    ByVal Thick As Double) As String
    Dim DefTxt As String
    DefTxt = IIf(Thick <= 0, vbNullString, CStr(Round(Thick, 3)))
    
    Dim Txt As String
    Do
        Txt = InputBox(Msg, , DefTxt)
        If Txt = vbNullString Then Exit Do
        If IsNumeric(Txt) Then Exit Do
        MsgBox "数字を入力して下さい!", vbOKOnly + vbExclamation
    Loop
    InputTxt = Txt
End Function

'ﾋﾞｭｰ非表示
Private Sub HideTPSView()
    With CATIA.ActiveDocument.Selection
        .Clear
        .Search "CATTPSSearch.CATTPSView,all"
        .VisProperties.SetShow catVisPropertyNoShowAttr
    End With
End Sub

'表示のUpdate
Private Sub UpdateScene(ByVal Scene As Variant)
    Dim Viewer As Viewer3D: Set Viewer = CATIA.ActiveWindow.ActiveViewer
    Dim VPnt3D As Variant 'Viewpoint3D
    Set VPnt3D = Viewer.Viewpoint3D
    
    Dim ary As Variant
    ary = KCL.GetRangeAry(Scene, 0, 2)
    Call VPnt3D.PutOrigin(ary)
    
    ary = KCL.GetRangeAry(Scene, 3, 5)
    Call VPnt3D.PutSightDirection(ary)
    
    ary = KCL.GetRangeAry(Scene, 6, 8)
    Call VPnt3D.PutUpDirection(ary)
    
    VPnt3D.FieldOfView = Scene(9)
    VPnt3D.FocusDistance = Scene(10)
    
    Call Viewer.Update
End Sub

'Viewpoint3Dからｼｰﾝ取得
Private Function GetScene3D(ViewPnt3D As Viewpoint3D) As Variant
    Dim vp As Variant: Set vp = ViewPnt3D
    
    Dim origin(2) As Variant: Call vp.GetOrigin(origin)
    
    Dim sight(2) As Variant: Call vp.GetSightDirection(sight)
    GetScene3D = KCL.JoinAry(origin, sight)
    
    Dim up(2) As Variant: Call vp.GetUpDirection(up)
    GetScene3D = KCL.JoinAry(GetScene3D, up)
    
    Dim FieldOfView(0) As Variant: FieldOfView(0) = vp.FieldOfView
    GetScene3D = KCL.JoinAry(GetScene3D, FieldOfView)
    
    Dim FocusDist(0) As Variant: FocusDist(0) = vp.FocusDistance
    GetScene3D = KCL.JoinAry(GetScene3D, FocusDist)
End Function

'現状の視点取得
Private Function GetViewPnt3D() As Viewpoint3D
    Set GetViewPnt3D = CATIA.ActiveWindow.ActiveViewer.Viewpoint3D
End Function

'注記
Private Sub CreateAnnotation( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal Arw As HybridShape, _
                    ByVal Rev As Boolean, _
                    ByVal Txt As String)
    '矢印端点座標取得 結構ｷﾞｬﾝﾌﾞﾙw
    Dim Idx As Long: Idx = IIf(Rev, 4, 3)
    Dim sel As Selection: Set sel = Pt.Parent.Selection
    Dim SelName As String
    With sel
        .Clear
        .Add Arw
        .Search "Topology.CGMVertex,sel"
        SelName = .Item2(Idx).Reference.Name
        .Clear
    End With
    
    Dim PntRef As Reference
    Set PntRef = Pt.CreateReferenceFromBRepName(KCL.GetBrepName(SelName), Arw)
    Dim Pnt As Variant 'HybridShapePointExplicit
    
    Set Pnt = Fact.AddNewPointDatum(PntRef)
    Dim Pos(2) As Variant 'Double
    Call Pnt.GetCoordinates(Pos)
    Call Fact.DeleteObjectForDatum(Pnt)
    
    'ｶﾒﾗ情報取得
    Dim NowVw As Variant
    NowVw = GetScene3D(GetViewPnt3D)
    
    'ｶﾒﾗ一時切り替え
    Call UpdateScene(Array(0, 0, 0, 0, 0, -1, 0, 1, 0, 0, 0))

    '注記
    Dim USurf As UserSurface
    Set USurf = Pt.UserSurfaces.Generate(PntRef)

    Dim ATSet As AnnotationSet
    Set ATSet = Pt.AnnotationSets.Add("")
    
    Dim Anno As Annotation
    Set Anno = ATSet.AnnotationFactory.CreateEvoluateText(USurf, Pos(0), Pos(1), Pos(2), False)
    Anno.Text.Text = Txt
    Call Pt.UpdateObject(Anno)
    
    'ｶﾒﾗ戻し
    Call UpdateScene(NowVw)
End Sub

'*** 厚み関連 ***
'ﾎﾞﾃﾞｨ面の時のみ、厚みの取得に挑戦
Private Function TryGetThickness( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal SurfRef As Reference, _
                    ByVal PntRef As Reference, _
                    ByVal Rev As Boolean) As Double
    TryGetThickness = -1#
    
    '親ﾎﾞﾃﾞｨ取得
    Dim PBody As Body: Set PBody = KCL.GetParent_Of_T(SurfRef, "Body")
    If KCL.IsNothing(PBody) Then Exit Function
    
    '履歴最後
    Dim Shps As Shapes: Set Shps = PBody.Shapes
    Dim ShpRef As Reference: Set ShpRef = Pt.CreateReferenceFromGeometry(Shps.Item(Shps.Count))
    
    'ｺﾞﾐ箱
    Dim DelList As Collection: Set DelList = New Collection
    
    '法線逆向き
    Rev = IIf(Rev, False, True)
    Dim LinRef As Reference
    Set LinRef = CreateNormalRef(Pt, Fact, SurfRef, PntRef, 0.002, 20000000#, Rev)
    Call DelList.Add(LinRef)
    
    '交差
    Dim InterRef As Reference
    Set InterRef = GetIntersectRef(Pt, Fact, ShpRef, LinRef)
    If KCL.IsNothing(InterRef) Then GoTo ExitGetThickness
    Call DelList.Add(InterRef)
    
    '近傍
    Dim NearRef As Reference
    Set NearRef = GetNearRef(Pt, Fact, InterRef, PntRef)
    Call DelList.Add(NearRef)
    
    '最短距離
    TryGetThickness = GetMaximumLength(Pt, PntRef, NearRef)
    
ExitGetThickness:

    'ｺﾞﾐ掃除
    Dim Ref As Reference
    For Each Ref In DelList
        Call Fact.DeleteObjectForDatum(Ref)
    Next
End Function

'最短距離測定
Private Function GetMaximumLength(ByVal Pt As Part, _
                                  ByVal Ref1 As Reference, _
                                  ByVal Ref2 As Reference) As Double
    GetMaximumLength = Pt.Parent.GetWorkbench("SPAWorkbench") _
                         .GetMeasurable(Ref1) _
                         .GetMinimumDistance(Ref2)
End Function

'近傍
Private Function GetNearRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal InterRef As Reference, _
                    ByVal PntRef As Reference) As Reference
    Dim Near As HybridShapeNear
    Set Near = Fact.AddNewNear(InterRef, PntRef)
    Call Pt.UpdateObject(Near)

    Set GetNearRef = Pt.CreateReferenceFromObject(Near)
End Function

'交差
Private Function GetIntersectRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal ShpRef As Reference, _
                    ByVal LinRef As Reference) As Reference
    Set GetIntersectRef = Nothing
    
    Dim Inter As HybridShapeIntersection
    Set Inter = Fact.AddNewIntersection(ShpRef, LinRef)
    Inter.PointType = 0
    
    On Error Resume Next
        Call Pt.UpdateObject(Inter)
        If Not Err.Number = 0 Then
            Err.Number = 0
            Call Fact.DeleteObjectForDatum(Inter)
            Exit Function
        End If
    On Error GoTo 0
    
    Set GetIntersectRef = Pt.CreateReferenceFromObject(Inter)
End Function

'*** 矢印関連 ***
'接合
Private Function CreateJoinRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal LinRef As Reference, _
                    ByVal PlyRef As Reference) As Reference
    Dim Join As HybridShapeAssemble
    Set Join = Fact.AddNewJoin(LinRef, PlyRef)
    With Join
        .SetConnex 1
        .SetManifold 0
        .SetSimplify 0
        .SetSuppressMode 0
        .SetDeviation 0.001
        .SetAngularToleranceMode 0
        .SetAngularTolerance 0.5
        .SetFederationPropagation 0
    End With
    Call Pt.UpdateObject(Join)
    
    Set CreateJoinRef = Pt.CreateReferenceFromObject(Join)
End Function

'折れ線
Private Function CreatePlyRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal Ref1 As Reference, _
                    ByVal Ref2 As Reference, _
                    ByVal Ref3 As Reference) As Reference
    Dim Ply As HybridShapePolyline
    Set Ply = Fact.AddNewPolyline()
    With Ply
        .InsertElement Ref1, 1
        .InsertElement Ref2, 2
        .InsertElement Ref3, 3
        .Closure = False
    End With
    Call Pt.UpdateObject(Ply)
    
    Set CreatePlyRef = Pt.CreateReferenceFromObject(Ply)
End Function

'端点
Private Function CreateEndPntRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal Crl As HybridShapeCircleCtrRad, _
                    ByVal StartEndFg As Boolean) As Reference
    Dim Cnt(2) As Variant
    Call Fact.GSMGetObjectFromReference(Crl.Center).GetCoordinates(Cnt)
    
    Dim R As Double
    R = Crl.Radius.Value
    
    Dim Pos(2) As Variant 'Double
    Dim Direct As HybridShapeDirection
    Set Direct = Crl.FirstDirection
    Pos(0) = Direct.GetXVal
    Pos(1) = Direct.GetYVal
    Pos(2) = Direct.GetZVal
    
    Dim i As Long
    For i = 0 To UBound(Pos)
        Pos(i) = (Pos(i) * R * IIf(StartEndFg, 1, -1)) + Cnt(i)
    Next
    
    Set CreateEndPntRef = CreatePntRef(Pt, Fact, Pos)
End Function

'円弧
Private Function CreateCrl( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal PntRef As Reference, _
                    ByVal PlnRef As Reference, _
                    ByVal Ang As Double, _
                    ByVal Leng As Double) As HybridShapeCircleCtrRad
    Dim PAI As Double: PAI = 4 * Atn(1)
    Dim R As Double: R = Tan((Ang * 0.5) * PAI / 180) * Leng
    Dim Crl As HybridShapeCircleCtrRad
    Set Crl = Fact.AddNewCircleCtrRadWithAngles(PntRef, PlnRef, False, R, 0#, 180#)
    Call Pt.UpdateObject(Crl)
    
    Set CreateCrl = Crl
End Function

'平面
Private Function CreatePlnRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal CrvRef As Reference, _
                    ByVal PntRef As Reference) As Reference
    Dim Pln As HybridShapePlaneNormal
    Set Pln = Fact.AddNewPlaneNormal(CrvRef, PntRef)
    Call Pt.UpdateObject(Pln)
    
    Set CreatePlnRef = Pt.CreateReferenceFromObject(Pln)
End Function

'点-線上
Private Function CreatePntOnCrvRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal CrvRef As Reference, _
                    ByVal Leng As Double, _
                    ByVal Rev As Boolean) As Reference
    Dim Pnt As HybridShapePointOnCurve
    Set Pnt = Fact.AddNewPointOnCurveFromDistance(CrvRef, Leng, Rev)
    Pnt.DistanceType = 1
    Call Pt.UpdateObject(Pnt)
    
    Set CreatePntOnCrvRef = Pt.CreateReferenceFromObject(Pnt)
End Function

'ﾃﾞｰﾀﾑ化
Private Function ToDatum( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal Ref As Reference) As HybridShape
    Dim Dtm As HybridShape ' HybridShapeCurveExplicit
    Set Dtm = Fact.AddNewCurveDatum(Ref)
    Call Pt.UpdateObject(Dtm)
    
    Set ToDatum = Dtm
End Function

'点
Private Function CreatePntRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal ary As Variant) As Reference
    Dim Pnt As HybridShapePointCoord
    Set Pnt = Fact.AddNewPointCoord(ary(0), ary(1), ary(2))
    Call Pt.UpdateObject(Pnt)
    
    Set CreatePntRef = Pt.CreateReferenceFromObject(Pnt)
End Function

'法線
Private Function CreateNormalRef( _
                    ByVal Pt As Part, _
                    ByVal Fact As HybridShapeFactory, _
                    ByVal SurfRef As Reference, _
                    ByVal PntRef As Reference, _
                    ByVal SLng As Double, _
                    ByVal ELng As Double, _
                    ByVal Rev As Boolean) As Reference
    Dim Lin As HybridShapeLineNormal
    Set Lin = Fact.AddNewLineNormal(SurfRef, PntRef, SLng, ELng, Rev)
    Call Pt.UpdateObject(Lin)
    Set CreateNormalRef = Pt.CreateReferenceFromObject(Lin)
End Function

かなり長めのｺｰﾄﾞになってしまいました。
実は、昨日の時点でほぼ出来上がっていたのですが、少し機能を
追加することにしました。

実行した際は、このような感じになります。

最初の動作はｻｰﾌｪｽをｸﾘｯｸした場合です。
２回目の操作はﾎﾞﾃﾞｨをｸﾘｯｸし、向きが相応しくない場合です。
３回目以降はﾎﾞﾃﾞｨをｸﾘｯｸし、意図した向きに矢印を作成した場合です。

３回目以降は、注記文字を入力する為のﾀﾞｲｱﾛｸﾞのﾃﾞﾌｫﾙﾄとして
数値が入っています。　これは自動で厚みを測定しています。
但し、条件によっては正しくない値が表示される為、完全ではない事を
考慮しておいてください。
(ｱﾎみたいな桁数にならないように、小数点以下３桁にしています)

･･･結構、ﾂｰﾙとして使えるかも。