穴軸とパイプ面作成マクロ[Type B]｜CATIAマクロの作成方法

今回の記事は「お問い合わせ」よりいただいた内容です。
送って頂いた内容は以下のようなマクロです。

●プロダクトファイル開いた状態で
　ツリーにぶら下がっているパートをアクティブにしてマクロを実行させたいです。
　
②穴軸とパイプ面作成　タイプB
　　選択　　　　　　　　　　　　　　　　　　　　　
　　　点を選択　＆　サーフェスを選択　（選択の点は選択するサーフェス上です。）　
　　　↓
　　結果　　　　　
　　　選択したサーフェスの面直線作成　と　作成された線に対してスイープ（中心と半径）
　
　・　A、Bの軸線及び面直線は点から両端で作成　（例　始点-10mmm,終点10mm)
　・　線片側長さとスイープ直径はダイアログで数値を入力　
（線片側長さは10と入力すれば始点-10mmm,終点10mm　全長は20mm,　
　　　スイープは入力時には直径の数値を入れたいです。）
　・　作成された線やスイープは作成後に履歴により寸法変更もしたいです。

複数のマクロ案を頂いたので、それぞれ別ページでまとめていきます。
(上記お問い合わせ内容に番号やタイプがついているのは複数案頂いたためです)

今回のマクロはユーザーが選択したオブジェクトを使って形状を作成するだけなので、作り方さえわかれば他の形状作成系マクロもすぐに使いこなせるようになります。

またCATProduct上で実行することを想定していますが、これにはちょっとしたテクニックが必要になるのでぜひここで押さえておきましょう。

※本ページの内容は「穴軸とパイプ面作成マクロ[Type A]」とほとんど同じです。
　コピペ部分もあるのでTypeAを理解している方は、流し読みでも理解できると思います。

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

マクロの機能

今回作成したマクロは
『ユーザーが選択した点とサーフェスに対して軸線とパイプ面を作成するマクロ』です。

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

マクロの機能まとめ・ユーザーにサーフェスとそのサーフェス上に乗っている点を選択させる
・点を通り、サーフェスに垂直方向の軸線とパイプ面を作成する
・軸線の長さとパイプ面の半径は作成前にインプットボックスで指定が可能
・作成した形状は全てツリー第1階層に作成する新規形状セットにまとめる

サンプルコード

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

Option Explicit

Sub CATMain()

    Dim SEL
    Set SEL = CATIA.ActiveDocument.Selection
    
    Dim filter1
    Dim filter2
    Dim Msg As String
    Dim status As String
    
label1:
    
    filter1 = Array("Face")
    Msg = "サーフェス(フェース)を選択してください。"
    
    status = SEL.SelectElement2(filter1, Msg, False)
    If status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelSurf As AnyObject
    Set SelSurf = SEL.Item(1).Value.Parent

    SEL.Clear

    filter2 = Array("Point")
    Msg = "点を選択して下さい。"
    
    status = SEL.SelectElement2(filter2, Msg, False)
    If status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelPoint As Point
    Set SelPoint = SEL.Item(1).Value
    
    SEL.Clear
    
    'SELPointを含むCATPart(PartDocumrnt)を取得
    
    Dim tmp_Obj
    Set tmp_Obj = SelPoint
    
    Do Until TypeName(tmp_Obj) = "PartDocument"
        Set tmp_Obj = tmp_Obj.Parent
    Loop
    
    Dim DOC As PartDocument
    Set DOC = tmp_Obj
        
    Dim PT As Part
    Set PT = DOC.Part
    
    
    '選択された点がサーフェスに乗っているか確認
    
    Dim RefPoint As Reference
    Dim RefSurf As Reference
    
    Set RefPoint = PT.CreateReferenceFromObject(SelPoint)
    Set RefSurf = PT.CreateReferenceFromObject(SelSurf)
    
    Dim SPA As Workbench
    Set SPA = DOC.GetWorkbench("SPAWorkbench")
    
    Dim ConfMeasure
    Set ConfMeasure = SPA.GetMeasurable(RefPoint)
    
    Dim getvalue As Variant
    getvalue = ConfMeasure.GetMinimumDistance(RefSurf)
    
    If getvalue <> 0 Then
        MsgBox "選択した点がサーフェスに乗っていません。" & vbLf & "選択し直してください。"
        GoTo label1
    End If
    
    Dim UserLength As String
    UserLength = InputBox("軸線の長さを入力して下さい。", "長さ入力", 10)
    If UserLength = "" Then
        Exit Sub
    End If
    
    Dim UserDiameter As String
    UserDiameter = InputBox("パイプ面の直径を入力して下さい。", "直径入力", 5)
    If UserDiameter = "" Then
        Exit Sub
    End If
    
    Dim HB As HybridBody
    Set HB = PT.HybridBodies.Add
    HB.Name = "穴軸とパイプ面作成(タイプB)"
    
    Dim HSF As HybridShapeFactory
    Set HSF = PT.HybridShapeFactory
    
    
    '① 選択された点を通り、サーフェスに直交な直線を作成
    
    Dim NormLine As HybridShapeLineNormal
    Set NormLine = HSF.AddNewLineNormal(RefSurf, RefPoint, UserLength, -1 * UserLength, False)
    
    HB.AppendHybridShape NormLine
    PT.Update

    
    '② ①を中心とするスイープを作成
    
    Dim RefLine As Reference
    Set RefLine = PT.CreateReferenceFromObject(NormLine)
    
    Dim PipeSweep As HybridShapeSweepCircle
    Set PipeSweep = HSF.AddNewSweepCircle(RefLine)
    
    PipeSweep.Mode = 6
    PipeSweep.SmoothActivity = False
    PipeSweep.GuideDeviationActivity = False
    PipeSweep.SetRadius 1, UserDiameter / 2
    PipeSweep.SetbackValue = 0.02
    PipeSweep.FillTwistedAreas = 1
    PipeSweep.C0VerticesMode = True
    
    HB.AppendHybridShape PipeSweep
    PT.Update
    
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

Option Explicit

Sub CATMain()

Dim SEL

Set SEL = CATIA.ActiveDocument.Selection

Dim filter1

Dim filter2

Dim Msg As String

Dim status As String

label1:

filter1 = Array("Face")

Msg = "サーフェス(フェース)を選択してください。"

status = SEL.SelectElement2(filter1, Msg, False)

If status <> "Normal" Then

MsgBox "キャンセルします。"

Exit Sub

End If

Dim SelSurf As AnyObject

Set SelSurf = SEL.Item(1).Value.Parent

SEL.Clear

filter2 = Array("Point")

Msg = "点を選択して下さい。"

status = SEL.SelectElement2(filter2, Msg, False)

If status <> "Normal" Then

MsgBox "キャンセルします。"

Exit Sub

End If

Dim SelPoint As Point

Set SelPoint = SEL.Item(1).Value

SEL.Clear

'SELPointを含むCATPart(PartDocumrnt)を取得

Dim tmp_Obj

Set tmp_Obj = SelPoint

Do Until TypeName(tmp_Obj) = "PartDocument"

Set tmp_Obj = tmp_Obj.Parent

Loop

Dim DOC As PartDocument

Set DOC = tmp_Obj

Dim PT As Part

Set PT = DOC.Part

'選択された点がサーフェスに乗っているか確認

Dim RefPoint As Reference

Dim RefSurf As Reference

Set RefPoint = PT.CreateReferenceFromObject(SelPoint)

Set RefSurf = PT.CreateReferenceFromObject(SelSurf)

Dim SPA As Workbench

Set SPA = DOC.GetWorkbench("SPAWorkbench")

Dim ConfMeasure

Set ConfMeasure = SPA.GetMeasurable(RefPoint)

Dim getvalue As Variant

getvalue = ConfMeasure.GetMinimumDistance(RefSurf)

If getvalue <> 0 Then

MsgBox "選択した点がサーフェスに乗っていません。" & vbLf & "選択し直してください。"

GoTo label1

End If

Dim UserLength As String

UserLength = InputBox("軸線の長さを入力して下さい。", "長さ入力", 10)

If UserLength = "" Then

Exit Sub

End If

Dim UserDiameter As String

UserDiameter = InputBox("パイプ面の直径を入力して下さい。", "直径入力", 5)

If UserDiameter = "" Then

Exit Sub

End If

Dim HB As HybridBody

Set HB = PT.HybridBodies.Add

HB.Name = "穴軸とパイプ面作成(タイプB)"

Dim HSF As HybridShapeFactory

Set HSF = PT.HybridShapeFactory

'① 選択された点を通り、サーフェスに直交な直線を作成

Dim NormLine As HybridShapeLineNormal

Set NormLine = HSF.AddNewLineNormal(RefSurf, RefPoint, UserLength, -1 * UserLength, False)

HB.AppendHybridShape NormLine

PT.Update

'② ①を中心とするスイープを作成

Dim RefLine As Reference

Set RefLine = PT.CreateReferenceFromObject(NormLine)

Dim PipeSweep As HybridShapeSweepCircle

Set PipeSweep = HSF.AddNewSweepCircle(RefLine)

PipeSweep.Mode = 6

PipeSweep.SmoothActivity = False

PipeSweep.GuideDeviationActivity = False

PipeSweep.SetRadius 1, UserDiameter / 2

PipeSweep.SetbackValue = 0.02

PipeSweep.FillTwistedAreas = 1

PipeSweep.C0VerticesMode = True

HB.AppendHybridShape PipeSweep

PT.Update

End Sub

コード解説

形状作成部分のコードは基本的に以下の①〜③を繰り返すだけなのでここでは割愛します。
① 形状の取得
② 取得した形状のReferenceを作成
③ ReferenceとHybridShapeFactoryを使って形状作成

以下では形状作成を行うまでのドキュメントの定義方法、ユーザー選択オブジェクトの確認などの形状作成部分以外のコードを解説していきます。
　

ドキュメントの定義

まずはドキュメントの定義を行います。
通常は「Set DOC = CATIA.ActiveDocument」のように1行で済ませることのできる「ドキュメントの定義」ですが、お問い合わせの内容によると「プロダクトファイル開いた状態でツリーにぶら下がっているパートをアクティブにしてマクロを実行させたいです。」とのことです。この場合、アクティブドキュメントはCATPartではなくCATProductになってしまうので、単純に「Set DOC = CATIA.ActiveDocument」と書いてしまうと以降の処理でCATPartの処理を行うことができません。

というわけでここでは少し違う方法を使ってドキュメント(CATPart)を定義していきます。

    Dim SEL
    Set SEL = CATIA.ActiveDocument.Selection
    
    Dim filter1
    Dim filter2
    Dim Msg As String
    Dim status As String
    
label1:
    
    filter1 = Array("Face")
    Msg = "サーフェス(フェース)を選択してください。"
    
    status = SEL.SelectElement2(filter1, Msg, False)
    If status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelSurf As AnyObject
    Set SelSurf = SEL.Item(1).Value.Parent

    SEL.Clear

    filter2 = Array("Point")
    Msg = "点を選択して下さい。"
    
    status = SEL.SelectElement2(filter2, Msg, False)
    If status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelPoint As Point
    Set SelPoint = SEL.Item(1).Value
    
    SEL.Clear
    
    'SELPointを含むCATPart(PartDocumrnt)を取得
    
    Dim tmp_Obj
    Set tmp_Obj = SelPoint
    
    Do Until TypeName(tmp_Obj) = "PartDocument"
        Set tmp_Obj = tmp_Obj.Parent
    Loop
    
    Dim DOC As PartDocument
    Set DOC = tmp_Obj

Dim SEL

Set SEL = CATIA.ActiveDocument.Selection

Dim filter1

Dim filter2

Dim Msg As String

Dim status As String

label1:

filter1 = Array("Face")

Msg = "サーフェス(フェース)を選択してください。"

status = SEL.SelectElement2(filter1, Msg, False)

If status <> "Normal" Then

MsgBox "キャンセルします。"

Exit Sub

End If

Dim SelSurf As AnyObject

Set SelSurf = SEL.Item(1).Value.Parent

SEL.Clear

filter2 = Array("Point")

Msg = "点を選択して下さい。"

status = SEL.SelectElement2(filter2, Msg, False)

If status <> "Normal" Then

MsgBox "キャンセルします。"

Exit Sub

End If

Dim SelPoint As Point

Set SelPoint = SEL.Item(1).Value

SEL.Clear

'SELPointを含むCATPart(PartDocumrnt)を取得

Dim tmp_Obj

Set tmp_Obj = SelPoint

Do Until TypeName(tmp_Obj) = "PartDocument"

Set tmp_Obj = tmp_Obj.Parent

Loop

Dim DOC As PartDocument

Set DOC = tmp_Obj

まずはドキュメントの定義はせず、ユーザーに「SelectElement2」を使ってサーフェスと点を選択させます。

次にこの点(サーフェスでも可)の親オブジェクトを順々に見ていき、PartDocumentオブジェクトになった時に、そのオブジェクトをドキュメントとして定義します。(コードでいうと「Do〜Loop」の部分)

点を選択し親オブジェクトを見ていくと
Point ＜ HybridShapes ＜ HybridBody ＜ HybridBodies ＜ Part ＜ PartDocument
といった具合に、必ず「PartDocument」が見つかります。

つまり「Until TypeName(tmp_Obj) = “PartDocument”」と条件をつければ、いつかはPartDocumentオブジェクトを取得できるというわけです。
実際に下のツリー構造で見てもCATPartを扱うPartDocumentオブジェクトは最上位のオブジェクトなので、親を順々に見ていけば必ず見つけることができるということがわかります。

ユーザーが選択した点とサーフェスが接しているかを確認

次にユーザーが選択した点とサーフェスが”接しているか”を確認していきます。
冒頭のお問い合わせ内容には記載されていませんが点とサーフェスは接していることが前提とのことなので、ここで両オブジェクトが接しているかを確認し、接していない場合は再度ユーザー選択のフェーズに戻るようにしておきます。

    Dim RefPoint As Reference
    Dim RefSurf As Reference
    
    Set RefPoint = PT.CreateReferenceFromObject(SelPoint)
    Set RefSurf = PT.CreateReferenceFromObject(SelSurf)
    
    Dim SPA As Workbench
    Set SPA = DOC.GetWorkbench("SPAWorkbench")
    
    Dim ConfMeasure
    Set ConfMeasure = SPA.GetMeasurable(RefPoint)
    
    Dim getvalue As Variant
    getvalue = ConfMeasure.GetMinimumDistance(RefSurf)
    
    If getvalue <> 0 Then
        MsgBox "選択した点がサーフェスに乗っていません。" & vbLf & "選択し直してください。"
        GoTo label1
    End If