C#ATIA

↑タイトル詐欺 主にFusion360API 偶にCATIA V5 VBA(絶賛ネタ切れ中)

UpdateとUpdateObject

"マクロで作成した面の色を変更したけど、上手く反映されない"
と言った内容の御質問を頂きました。

このような状態のデータで、オフセット面を作成する操作の
マクロを記録しました。

f:id:kandennti:20170612170332p:plain

'vba
Sub CATMain()
    Dim partDocument1 As PartDocument
    Set partDocument1 = CATIA.ActiveDocument
    
    Dim part1 As Part
    Set part1 = partDocument1.Part
    
    Dim parameters1 As Parameters
    Set parameters1 = part1.Parameters
    
    Dim hybridShapeSurfaceExplicit1 As HybridShapeSurfaceExplicit
    Set hybridShapeSurfaceExplicit1 = parameters1.Item("サーフェス.1")
    
    Dim reference1 As Reference
    Set reference1 = part1.CreateReferenceFromObject(hybridShapeSurfaceExplicit1)
    
    Dim hybridShapeFactory1 As HybridShapeFactory
    Set hybridShapeFactory1 = part1.HybridShapeFactory
    
    Dim hybridShapeOffset1 As HybridShapeOffset
    Set hybridShapeOffset1 = hybridShapeFactory1.AddNewOffset(reference1, 5#, True, 0.01)
    
    Dim hybridBodies1 As HybridBodies
    Set hybridBodies1 = part1.HybridBodies
    
    Dim hybridBody1 As HybridBody
    Set hybridBody1 = hybridBodies1.Item("形状セット.1")
    
    hybridBody1.AppendHybridShape hybridShapeOffset1
    
    part1.InWorkObject = hybridShapeOffset1
    
    part1.Update
End Sub

色を変更する為の(手抜き感たっぷりな)関数をこんな感じで作成しました。

'色設定
Private Sub SetColor(ByVal Surf As HybridShapeOffset)
    With CATIA.ActiveDocument.Selection
        .Clear
        .Add Surf
        .VisProperties.SetRealColor 0, 255, 0, 1
        .Clear
    End With
End Sub

引数に渡されたオフセットなオブジェクトを緑色に変更するだけです。

問題は、このSetColor関数をCatMainの何処に記載するか? です。


一番問題ないのが、一番最後の位置です。

	・・・
    hybridBody1.AppendHybridShape hybridShapeOffset1
    
    part1.InWorkObject = hybridShapeOffset1
    
    part1.Update
    
    Call SetColor(hybridShapeOffset1) '追加
End Sub

御質問頂いた方の場合は、こんな感じのコードでした。

	・・・
    hybridBody1.AppendHybridShape hybridShapeOffset1
    
    part1.InWorkObject = hybridShapeOffset1
    
    Call SetColor(hybridShapeOffset1) '追加
    
    part1.Update
End Sub

ご本人も "Updateの後に色の変更であれば可能" と言う認識は
されておりました。

そこでちょっと意地悪く、こんなコードにしてみます。

	・・・
    'hybridBody1.AppendHybridShape hybridShapeOffset1 'コメント化
    
    part1.InWorkObject = hybridShapeOffset1
    
    part1.Update
    
    Call SetColor(hybridShapeOffset1) '追加
    
    hybridBody1.AppendHybridShape hybridShapeOffset1 '追加
    
    part1.Update

アップデート後に色は変えるものの、形状セットに入れる(AppendHybridShape)
のは、後回しにします。 この場合、色は変更されませんでした。

この事から、
・色の変更は、アップデート後に行う。
・アップデートする前に、形状セットに入れておく必要がある。

と言うことになりそうです。


そこで、このようなコードを提案してみました。

	・・・
    Dim hybridShapeOffset1 As HybridShapeOffset
    Set hybridShapeOffset1 = hybridShapeFactory1.AddNewOffset(reference1, 5#, True, 0.01)
    
    Call part1.UpdateObject(hybridShapeOffset1) '追加
    Call SetColor(hybridShapeOffset1) '追加
    
    Dim hybridBodies1 As HybridBodies
    Set hybridBodies1 = part1.HybridBodies
	・・・

オフセット面を作成(AddNewOffset)し、形状セットに入れる前に
UpdateObjectメソッドでアップデートし、色を変更する手順です。

UpdateObjectメソッドであれば、Updateメソッドと異なり、
形状セットに入れておく必要がありません。 

実はこの方法を利用すると、一時的に必要な要素を形状セットに入れる
必要が無くなる為、処理が非常に速くなります。
(場合によっては遅くなります)

DrawをPDFでエクスポート (未解決)

こちらの記載を見てみると、DrawをPDFに高速で変換する方法を
お探しのようでした。

Fastest way to convert CATDrawing to PDF - DASSAULT: CATIA products - Eng-Tips

添付されているマクロを見ても、結局開いてPDFとして保存してました。
恐らくそれしか方法無いのでしょうね。

久しく起動していないバッチマネージメントを見ても、無いんですね。

アドバイスとして "バッチモードでやれば速いよ" って事のようです。


ところで、DrawをPDFでエクスポートする際、複数のシートが存在している場合、
一つのPDFファイルにするか? シート毎にPDFファイルにするか?
は、オプションの設定で出来ると思うのですが、
狙ったシートだけをPDF化する って出来るんですかね?
(何時も、シート毎にPDF化の設定で行い、不要なものを捨ててます)

クリックした面に3Dな矢印と注記を作る

こちらの続きです。
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

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

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

最初の動作はサーフェスをクリックした場合です。
2回目の操作はボディをクリックし、向きが相応しくない場合です。
3回目以降はボディをクリックし、意図した向きに矢印を作成した場合です。

3回目以降は、注記文字を入力する為のダイアログのデフォルトとして
数値が入っています。 これは自動で厚みを測定しています。
但し、条件によっては正しくない値が表示される為、完全ではない事を
考慮しておいてください。
(アホみたいな桁数にならないように、小数点以下3桁にしています)

・・・結構、ツールとして使えるかも。

3Dな注記の位置を制御出来ているっぽい(条件付き)

こちらの続きです。
3Dな注記の位置を制御したい - C#ATIA

前回はX軸が縦になった状態の場合、注記が意図しない位置に
出来上がってしまいました。
最後に "一瞬だけ画面を動かせば" と書いたのですが、
実際に取り入れたところ、上手く行っているように感じます。

こちらの動画の最初は、前回失敗していた時と同様の向きです。

他の向きも矢印付近に出来ています。
作成する向きによっては、若干のズレはありますが
これ以上は手動で修正して欲しいところ。
(どの矢印に対しての注記か? は、わかるレベルだと思います)

実は問題が無いわけでもなく、注釈セット内のビューが既に有り
意図していない(XY平面と同一の向きになっていない)ビューが
アクティブになっていた場合、やはりおかしい位置に出来てしまいます。

TPSViewクラスから何も取得できない以上、これぐらいが限界かな?

3Dな注記の位置を制御したい

こちらの続きです。
クリックした面に3Dな矢印を作る - C#ATIA


注記の追加に取り掛かっているのですが、やはり注記の位置を制御
するのに困っています。

未完成の為、コード無しですがこのような感じまでは出来ています。

動画の最初の操作では、意図した位置に出来上がるようになったのですが
二度目の操作ではかけ離れた位置に出来てしまいます。

これらの操作の違いは、画面の向いている方向に影響されているようです。
(座標系又はコンパスのXY平面に注目)
現状のコードでは画面がXY平面に近い状態であれば、意図した位置になることが
わかってきました。

と言うことは、こちらの注記のサポートのビュー(正しい名称がわかりません)の
影響が大きい事が何となくわかってはいます。(TPSViewクラス)
f:id:kandennti:20170606174200p:plain

マクロの記録では記載されず、自動的に作成されるこのビュー自体を
作ってしまおう! と考えたのですが
f:id:kandennti:20170606174210p:plain

生憎、ライセンスが無く出来ませんでした・・・。


注記を作る際、一瞬だけ画面を動かせば何とかなるのかな?

クリックした面に3Dな矢印を作る

タイトルが異なりますが、こちらの続きです。
クリックした面に法線を作成する - C#ATIA

こちらでコメント頂いている矢の部分ですが、
昨日自宅で、どの様な定義をすれば良いのか思いついたので
コードを作成してみました。
(このような事は案外、PCの前に居ない時に思いつきますね)

'vba sample_CreateArrow_ver0.0.1  using-'ver0.0.10'
'クリックした面に矢印を作成

Option Explicit

Private Const ArwBodyLeng = 20#
Private Const ArwLeng = 5#
Private Const ArwAng = 30#

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 = False
    Dim Msg As String: Msg = "向きを逆転しますか?"
    Dim HBdy As HybridBody
    
    Do
        '法線
        Dim LinRef As Reference
        Set LinRef = CreateNormalRef(Pt, Fact, SurfRef, PntRef, 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 HybridShapeLineExplicit
        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 Ref As Reference
    For Each Ref In DelList
        Call Fact.DeleteObjectForDatum(Ref)
    Next
    
    MsgBox "Done"
End Sub

'接合
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 HybridShapeLineExplicit
    Dim Dtm As HybridShapeLineExplicit
    Set Dtm = Fact.AddNewLineDatum(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 Lng As Double, _
                    ByVal Rev As Boolean) As Reference
    Dim Lin As HybridShapeLineNormal
    Set Lin = Fact.AddNewLineNormal(SurfRef, PntRef, 0#, Lng, Rev)
    Call Pt.UpdateObject(Lin)
    Call Pt.Update
    
    Set CreateNormalRef = Pt.CreateReferenceFromObject(Lin)
End Function

矢印のサイズは調節しやすいように、先頭付近の定数にしています。
それぞれの意味はこちらの画像の状態です。

f:id:kandennti:20170606145028p:plain
実行時、矢印の向きが意図しない方向に出来上がる可能性がある為
一度作成後、確認用のダイアログが出現します。
f:id:kandennti:20170606145039p:plain
反転する必要がある場合は "はい" を選択してください。


御質問頂いたsauvignon1962さんは、「選択した面の中心に・・」
と書かれていますが "中心" を定義するのが難しいです。
この "中心" を仮に "重心" と捉えた場合、下記の画像の様に
中央部分が抜けた面を指定した場合、
f:id:kandennti:20170606145049p:plain
中央部の点部分に矢印を作成する事になります。
当然、意図した位置では無い為、混乱を招く恐れがあるかと思います。

その為、前回のサンプル同様にクリックした面上の位置に矢印を作成
するようにしています。
(クリック出来る以上、確実に目的の面が存在しているはずです)


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

注記については、これから調べます。
・・・これらの動画はAutodeskのScreencastを利用しているのですが、
CATIAの動画ばかりUpしてて大丈夫なのかな?
(ごっそり削除されちゃうかな?)

マクロで干渉レポートを作成する

こちらのコメントに記載した、マクロで干渉レポートを作成するサンプルを
作成しました。
クリックした面に法線を作成する - C#ATIA


コードはこちら。

'vba sample_ClashReport_ver0.01  using-'ver0.0.10'
'指定した2つのプロダクトの干渉チェックをします

Option Explicit

Sub CATMain()
    'ドキュメントのチェック
    If Not CanExecute("ProductDocument") Then Exit Sub
    
    'トッププロダクト取得
    Dim TopProd As Product: Set TopProd = CATIA.ActiveDocument.Product
    Dim Path As String: Path = TopProd.Parent.Path
    If Path = vbNullString Then
        MsgBox "トッププロダクトは、一度保存されたファイルにして下さい!"
        Exit Sub
    End If
    
    '選択
    Dim Msg As String: Msg = "個目のプロダクトを選択してください"
    Dim Prod1 As Product: Set Prod1 = KCL.SelectItem("1" & Msg, "Product")
    If KCL.IsNothing(Prod1) Then Exit Sub
    
    Dim Prod2 As Product: Set Prod2 = KCL.SelectItem("2" & Msg, "Product")
    If KCL.IsNothing(Prod2) Then Exit Sub
    
    '選択チェック
    If Prod1 Is Prod2 Then
        MsgBox "同一プロダクトの干渉チェックは出来ません!"
        Exit Sub
    End If
    
    '干渉チェック
    Dim Grps As Groups: Set Grps = TopProd.GetTechnologicalObject("Groups")
    Dim Grp1 As Group: Set Grp1 = Grps.Add
    Call Grp1.AddExplicit(Prod1)
    Dim Grp2 As Group: Set Grp2 = Grps.Add
    Call Grp2.AddExplicit(Prod2)
    
    Dim Clashes As Clashes: Set Clashes = TopProd.GetTechnologicalObject("Clashes")
    Dim Clash As Clash: Set Clash = Clashes.Add
    
    With Clash
        .Clearance = 0.1
        .ComputationType = catClashComputationTypeBetweenTwo
        .InterferenceType = catClashInterferenceTypeClearance
        .FirstGroup = Grp1
        .SecondGroup = Grp2
        .Compute
    End With
    
    '干渉結果
    If Clash.Conflicts.Count > 0 Then
        Dim CRPath As String: CRPath = Path & "\ClashReport\ClashReport"
        Call Clash.Export(CatClashExportTypeXMLResultOnly, CRPath)
        CreateObject("Shell.Application").ShellExecute CRPath & ".xml"
        
        SendKeys "{ESC}", False 'この行が無いと、マクロ実行後のCATIAの挙動が怪しい
    Else
        MsgBox "干渉はありません"
    End If
End Sub

レポートファイルを作成する都合上、トップのプロダクトは一度保存されている
必要があります。

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

干渉チェックする際の条件等は、コードを修正する必要があります。