長穴中心線(座標軸線)作成マクロ｜CATIAマクロの作成方法

今回の記事は「お問い合わせ」より頂いた内容です。

今回の内容は以前作成した「穴中心線(座標軸線)作成マクロ」の派生マクロです。
そのためコードの内容がほとんど同じなので、本ページでコード解説は行っていません。
コードの内容を理解したい方は上記マクロのページを参照下さい。

Contents

1. マクロの機能
2. サンプルコード
3. まとめ

マクロの機能

今回作成したマクロは
『ユーザーが選択した長円エッジに対して穴中心線(座標軸線)を作成するマクロ』です。

具体的な機能は以下のとおりです。

マクロの機能まとめ・ユーザーに長穴エッジ(両側の円弧)を選択させる
・選択された長円エッジに対して軸線を作成する
・作成した形状は全てツリー第1階層に作成する新規形状セットにまとめる

サンプルコード

マクロのサンプルコードは以下のとおりです。

Option Explicit

Sub CATMain()

    Dim SEL
    Set SEL = CATIA.ActiveDocument.Selection
    
    Dim VPS As VisPropertySet
    Set VPS = SEL.VisProperties
    
    Dim filter1
    Dim filter2
    Dim msg As String
    Dim Status As String
    
    filter1 = Array("BiDimFeatEdge")
    msg = "エッジ1(円弧)を選択して下さい。"
    
label1:
    
    Status = SEL.SelectElement2(filter1, msg, False)
    If Status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelEdge1 As Edge
    Set SelEdge1 = SEL.Item(1).Value
    
    SEL.Clear
    
    'エッジを含むCATPart(PartDocumrnt)を取得
    
    Dim tmp_Obj
    Set tmp_Obj = SelEdge1
    
    Do Until TypeName(tmp_Obj) = "PartDocument"
        Set tmp_Obj = tmp_Obj.Parent
    Loop
    
    Dim Doc As PartDocument
    Set Doc = tmp_Obj
    
    
    '選択されたエッジが円か確認
    
    Dim SPA As Workbench
    Set SPA = Doc.GetWorkbench("SPAWorkbench")
    
    Dim ConfMeasure
    Set ConfMeasure = SPA.GetMeasurable(SelEdge1)
    
    Dim check As Boolean
    check = False
    
    On Error GoTo ErrLabel
        Dim getvalues1(2) As Variant
        ConfMeasure.GetCenter getvalues1
    On Error GoTo 0
    
    Dim Radius1 As Double
    Radius1 = ConfMeasure.Radius
    
    check = True
    
    
label2:
    
    filter2 = Array("BiDimFeatEdge")
    msg = "エッジ2(円弧)を選択して下さい。"
    
    Status = SEL.SelectElement2(filter2, msg, False)
    If Status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelEdge2 As Edge
    Set SelEdge2 = SEL.Item(1).Value

    SEL.Clear
    
    
    Set ConfMeasure = SPA.GetMeasurable(SelEdge2)
    
    On Error GoTo ErrLabel
        Dim getvalues2(2) As Variant
        ConfMeasure.GetCenter getvalues1
    On Error GoTo 0
    
    Dim Radius2 As Double
    Radius2 = ConfMeasure.Radius
    

    Dim PT As Part
    Set PT = Doc.Part

    Dim HB As HybridBody
    Set HB = PT.HybridBodies.Add
    HB.Name = "長穴中心線(座標軸線)"

    Dim HSF As HybridShapeFactory
    Set HSF = PT.HybridShapeFactory
    


    '① 選択されたエッジの中心点作成

    Dim EdgeCtrPoint1 As Point
    Set EdgeCtrPoint1 = HSF.AddNewPointCenter(SelEdge1)

    HB.AppendHybridShape EdgeCtrPoint1
    PT.Update
    
    Dim EdgeCtrPoint2 As Point
    Set EdgeCtrPoint2 = HSF.AddNewPointCenter(SelEdge2)

    HB.AppendHybridShape EdgeCtrPoint2
    PT.Update
    
    
    '② 選択されたエッジを通る平面を作成
    
    Dim NormPlane As Plane
    Set NormPlane = HSF.AddNewPlane1Curve(SelEdge1)
    
    HB.AppendHybridShape NormPlane
    PT.Update
    

    '③ ①の2点を通る直線を作成

    Dim RefPoint1 As Reference
    Set RefPoint1 = PT.CreateReferenceFromObject(EdgeCtrPoint1)
    
    Dim RefPoint2 As Reference
    Set RefPoint2 = PT.CreateReferenceFromObject(EdgeCtrPoint2)
    
    Dim RefPlane As Reference
    Set RefPlane = PT.CreateReferenceFromObject(NormPlane)

    Dim AxisLine1 As Line
    Set AxisLine1 = HSF.AddNewLinePtPtOnSupportExtended(RefPoint1, RefPoint2, RefPlane, Radius1 + 5, Radius2 + 5)

    HB.AppendHybridShape AxisLine1
    PT.Update
    
    
    '④ ③で作成した直線の中心点を作成
    
    Dim RefAxisLine1 As Reference
    Set RefAxisLine1 = PT.CreateReferenceFromObject(AxisLine1)
    
    Dim CtrPoint As Point
    Set CtrPoint = HSF.AddNewPointOnCurveFromPercent(RefAxisLine1, 0.5, False)
    
    HB.AppendHybridShape CtrPoint
    PT.Update
    
    
    '⑤ ④を通り②に直交な直線を作成
    
    Dim RefCtrPoint As Reference
    Set RefCtrPoint = PT.CreateReferenceFromObject(CtrPoint)
    
    Dim AxisLine2 As HybridShapeLineNormal
    Set AxisLine2 = HSF.AddNewLineNormal(RefPlane, RefCtrPoint, 10, -10, False)
    
    HB.AppendHybridShape AxisLine2
    PT.Update
    
    
    '⑥ ③の直線を⑤の直線を軸に90deg回転した位置に直線を作成
    
    Dim RefAxisLine As Reference
    Set RefAxisLine = PT.CreateReferenceFromObject(AxisLine1)
    
    Dim AxisLine3 As Line
    Set AxisLine3 = HSF.AddNewLineAngle(RefAxisLine1, RefPlane, RefCtrPoint, True, Radius1 + 5, -1 * (Radius2 + 5), 90, False)
    
    HB.AppendHybridShape AxisLine3
    PT.Update
    
    
    With SEL
        .Add EdgeCtrPoint1
        .Add EdgeCtrPoint2
        .Add NormPlane
    End With
    
    VPS.SetShow catVisPropertyNoShowAttr
    SEL.Clear

    Exit Sub

ErrLabel:

    MsgBox "エッジは円弧を選択してください。"
    SEL.Clear
    
    If check = False Then
        Resume label1
    ElseIf check = True Then
        Resume label2
    End If
        
End Sub