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

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

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

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

マクロの機能

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

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

マクロの機能まとめ・ユーザーに四角穴エッジ(長辺と短辺の直線エッジ)を選択させる
・選択された四角穴エッジに対して軸線を作成する
・作成した形状は全てツリー第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("RectilinearBiDimFeatEdge")
    msg = "エッジ1(直線)を選択してください。"
    
    Status = SEL.SelectElement2(filter1, msg, False)
    If Status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelEdge1 As BiDimFeatEdge
    Set SelEdge1 = SEL.Item(1).Value

    SEL.Clear

    filter2 = Array("RectilinearBiDimFeatEdge")
    msg = "エッジ2(直線)を選択してください。"
    
    Status = SEL.SelectElement2(filter2, msg, False)
    If Status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelEdge2 As BiDimFeatEdge
    Set SelEdge2 = SEL.Item(1).Value
    
    SEL.Clear
    
    'SELPointを含む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
    Dim Edge1Length As Double
    Dim Edge2Length As Double
    
    Set ConfMeasure = SPA.GetMeasurable(SelEdge1)
    Edge1Length = ConfMeasure.Length
    
    Set ConfMeasure = SPA.GetMeasurable(SelEdge2)
    Edge2Length = ConfMeasure.Length
    
    
    Dim ConfAngle As Double
    ConfAngle = ConfMeasure.GetAngleBetween(SelEdge1)
    
    ConfAngle = Format(ConfAngle, "0.000")
    
    Dim ConfDistance As Double
    ConfDistance = ConfMeasure.GetMinimumDistance(SelEdge1)
    
    ConfDistance = Format(ConfDistance, "0.000")
    
    If ConfAngle <> 90 Or ConfDistance <> 0 Then
        MsgBox "選択されたエッジが有効ではないためマクロを中断します。" & vbLf & "四角穴の長辺/短辺エッジを選択して下さい。"
        Exit Sub
    End If
    

    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 CtrPoint1 As Point
    Set CtrPoint1 = HSF.AddNewPointOnCurveFromPercent(SelEdge1, 0.5, False)
    HB.AppendHybridShape CtrPoint1
    PT.Update
    
    Dim CtrPoint2 As Point
    Set CtrPoint2 = HSF.AddNewPointOnCurveFromPercent(SelEdge2, 0.5, False)
    HB.AppendHybridShape CtrPoint2
    PT.Update

    
    '② ①を始点に選択したエッジ方向の直線を作成
    
    Dim HSdir1 As HybridShapeDirection
    Dim HSdir2 As HybridShapeDirection
    Set HSdir1 = HSF.AddNewDirection(SelEdge1)
    Set HSdir2 = HSF.AddNewDirection(SelEdge2)

    Dim RefCtrPoint1 As Reference
    Dim RefCtrPoint2 As Reference
    Set RefCtrPoint1 = PT.CreateReferenceFromObject(CtrPoint1)
    Set RefCtrPoint2 = PT.CreateReferenceFromObject(CtrPoint2)

    Dim Line1 As HybridShapeLinePtDir
    Set Line1 = HSF.AddNewLinePtDir(RefCtrPoint1, HSdir2, Edge2Length, -1 * Edge2Length, False)
    HB.AppendHybridShape Line1
    PT.Update

    Dim Line2 As HybridShapeLinePtDir
    Set Line2 = HSF.AddNewLinePtDir(RefCtrPoint2, HSdir1, Edge1Length, -1 * Edge1Length, False)
    HB.AppendHybridShape Line2
    PT.Update
    
    
    '③ ②の2直線の交点を作成
    
    Dim RefLine1 As Reference
    Dim RefLine2 As Reference
    Set RefLine1 = PT.CreateReferenceFromObject(Line1)
    Set RefLine2 = PT.CreateReferenceFromObject(Line2)
    
    Dim SectPoint As HybridShapeIntersection
    Set SectPoint = HSF.AddNewIntersection(RefLine1, RefLine2)
    HB.AppendHybridShape SectPoint
    PT.Update

    
    '④ ③を始点にエッジ方向に直線を作成
    
    Dim RefSectPoint As Reference
    Set RefSectPoint = PT.CreateReferenceFromObject(SectPoint)
    
    Dim AxisLine1 As Line
    Set AxisLine1 = HSF.AddNewLinePtDir(RefSectPoint, HSdir1, (Edge1Length / 2) + 5, -1 * ((Edge1Length / 2) + 5), False)
    HB.AppendHybridShape AxisLine1
    PT.Update
    
    Dim AxisLine2 As Line
    Set AxisLine2 = HSF.AddNewLinePtDir(RefSectPoint, HSdir2, (Edge2Length / 2) + 5, -1 * ((Edge2Length / 2) + 5), False)
    HB.AppendHybridShape AxisLine2
    PT.Update
    
    
    '⑤ ④の2直線を通る平面を作成
    
    Dim RefAxisLine1 As Reference
    Dim RefAxisLine2 As Reference
    Set RefAxisLine1 = PT.CreateReferenceFromObject(AxisLine1)
    Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)
    
    Dim NormPlane As HybridShapePlane2Lines
    Set NormPlane = HSF.AddNewPlane2Lines(RefAxisLine1, RefAxisLine2)
    HB.AppendHybridShape NormPlane
    PT.Update
    
    
    '⑥ ③を始点とし⑤に直交方向の直線を作成
    
    Dim HSDir3 As HybridShapeDirection
    Set HSDir3 = HSF.AddNewDirection(NormPlane)
    
    Dim AxisLine3 As Line
    Set AxisLine3 = HSF.AddNewLinePtDir(RefSectPoint, HSDir3, 10, -10, False)
    HB.AppendHybridShape AxisLine3
    PT.Update
    

    With SEL
        .Add CtrPoint1
        .Add CtrPoint2
        .Add Line1
        .Add Line2
        .Add NormPlane
    End With
    
    VPS.SetShow catVisPropertyNoShowAttr
    SEL.Clear

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

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

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("RectilinearBiDimFeatEdge")

msg = "エッジ1(直線)を選択してください。"

Status = SEL.SelectElement2(filter1, msg, False)

If Status <> "Normal" Then

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

Exit Sub

End If

Dim SelEdge1 As BiDimFeatEdge

Set SelEdge1 = SEL.Item(1).Value

SEL.Clear

filter2 = Array("RectilinearBiDimFeatEdge")

msg = "エッジ2(直線)を選択してください。"

Status = SEL.SelectElement2(filter2, msg, False)

If Status <> "Normal" Then

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

Exit Sub

End If

Dim SelEdge2 As BiDimFeatEdge

Set SelEdge2 = SEL.Item(1).Value

SEL.Clear

'SELPointを含む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

Dim Edge1Length As Double

Dim Edge2Length As Double

Set ConfMeasure = SPA.GetMeasurable(SelEdge1)

Edge1Length = ConfMeasure.Length

Set ConfMeasure = SPA.GetMeasurable(SelEdge2)

Edge2Length = ConfMeasure.Length

Dim ConfAngle As Double

ConfAngle = ConfMeasure.GetAngleBetween(SelEdge1)

ConfAngle = Format(ConfAngle, "0.000")

Dim ConfDistance As Double

ConfDistance = ConfMeasure.GetMinimumDistance(SelEdge1)

ConfDistance = Format(ConfDistance, "0.000")

If ConfAngle <> 90 Or ConfDistance <> 0 Then

MsgBox "選択されたエッジが有効ではないためマクロを中断します。" & vbLf & "四角穴の長辺/短辺エッジを選択して下さい。"

Exit Sub

End If

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 CtrPoint1 As Point

Set CtrPoint1 = HSF.AddNewPointOnCurveFromPercent(SelEdge1, 0.5, False)

HB.AppendHybridShape CtrPoint1

PT.Update

Dim CtrPoint2 As Point

Set CtrPoint2 = HSF.AddNewPointOnCurveFromPercent(SelEdge2, 0.5, False)

HB.AppendHybridShape CtrPoint2

PT.Update

'② ①を始点に選択したエッジ方向の直線を作成

Dim HSdir1 As HybridShapeDirection

Dim HSdir2 As HybridShapeDirection

Set HSdir1 = HSF.AddNewDirection(SelEdge1)

Set HSdir2 = HSF.AddNewDirection(SelEdge2)

Dim RefCtrPoint1 As Reference

Dim RefCtrPoint2 As Reference

Set RefCtrPoint1 = PT.CreateReferenceFromObject(CtrPoint1)

Set RefCtrPoint2 = PT.CreateReferenceFromObject(CtrPoint2)

Dim Line1 As HybridShapeLinePtDir

Set Line1 = HSF.AddNewLinePtDir(RefCtrPoint1, HSdir2, Edge2Length, -1 * Edge2Length, False)

HB.AppendHybridShape Line1

PT.Update

Dim Line2 As HybridShapeLinePtDir

Set Line2 = HSF.AddNewLinePtDir(RefCtrPoint2, HSdir1, Edge1Length, -1 * Edge1Length, False)

HB.AppendHybridShape Line2

PT.Update

'③ ②の2直線の交点を作成

Dim RefLine1 As Reference

Dim RefLine2 As Reference

Set RefLine1 = PT.CreateReferenceFromObject(Line1)

Set RefLine2 = PT.CreateReferenceFromObject(Line2)

Dim SectPoint As HybridShapeIntersection

Set SectPoint = HSF.AddNewIntersection(RefLine1, RefLine2)

HB.AppendHybridShape SectPoint

PT.Update

'④ ③を始点にエッジ方向に直線を作成

Dim RefSectPoint As Reference

Set RefSectPoint = PT.CreateReferenceFromObject(SectPoint)

Dim AxisLine1 As Line

Set AxisLine1 = HSF.AddNewLinePtDir(RefSectPoint, HSdir1, (Edge1Length / 2) + 5, -1 * ((Edge1Length / 2) + 5), False)

HB.AppendHybridShape AxisLine1

PT.Update

Dim AxisLine2 As Line

Set AxisLine2 = HSF.AddNewLinePtDir(RefSectPoint, HSdir2, (Edge2Length / 2) + 5, -1 * ((Edge2Length / 2) + 5), False)

HB.AppendHybridShape AxisLine2

PT.Update

'⑤ ④の2直線を通る平面を作成

Dim RefAxisLine1 As Reference

Dim RefAxisLine2 As Reference

Set RefAxisLine1 = PT.CreateReferenceFromObject(AxisLine1)

Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)

Dim NormPlane As HybridShapePlane2Lines

Set NormPlane = HSF.AddNewPlane2Lines(RefAxisLine1, RefAxisLine2)

HB.AppendHybridShape NormPlane

PT.Update

'⑥ ③を始点とし⑤に直交方向の直線を作成

Dim HSDir3 As HybridShapeDirection

Set HSDir3 = HSF.AddNewDirection(NormPlane)

Dim AxisLine3 As Line

Set AxisLine3 = HSF.AddNewLinePtDir(RefSectPoint, HSDir3, 10, -10, False)

HB.AppendHybridShape AxisLine3

PT.Update

With SEL

.Add CtrPoint1

.Add CtrPoint2

.Add Line1

.Add Line2

.Add NormPlane

End With

VPS.SetShow catVisPropertyNoShowAttr

SEL.Clear

End Sub

コード解説

基本的には冒頭でもいったとおり「穴中心線(座標軸線)作成マクロ」と同じような内容が多いため、共通部分は割愛しています。
　

ユーザー選択のエッジを確認

ユーザーが選択した四角穴の長辺エッジと短辺エッジが、本当に四角穴エッジなのかを確認します。

    Dim ConfMeasure
    Dim Edge1Length As Double
    Dim Edge2Length As Double
    
    Set ConfMeasure = SPA.GetMeasurable(SelEdge1)
    Edge1Length = ConfMeasure.Length
    
    Set ConfMeasure = SPA.GetMeasurable(SelEdge2)
    Edge2Length = ConfMeasure.Length
    
    
    Dim ConfAngle As Double
    ConfAngle = ConfMeasure.GetAngleBetween(SelEdge1)
    
    ConfAngle = Format(ConfAngle, "0.000")
    
    Dim ConfDistance As Double
    ConfDistance = ConfMeasure.GetMinimumDistance(SelEdge1)
    
    ConfDistance = Format(ConfDistance, "0.000")
    
    If ConfAngle <> 90 Or ConfDistance <> 0 Then
        MsgBox "選択されたエッジが有効ではないためマクロを中断します。" & vbLf & "四角穴の長辺/短辺エッジを選択して下さい。"
        Exit Sub
    End If

Dim ConfMeasure

Dim Edge1Length As Double

Dim Edge2Length As Double

Set ConfMeasure = SPA.GetMeasurable(SelEdge1)

Edge1Length = ConfMeasure.Length

Set ConfMeasure = SPA.GetMeasurable(SelEdge2)

Edge2Length = ConfMeasure.Length

Dim ConfAngle As Double

ConfAngle = ConfMeasure.GetAngleBetween(SelEdge1)

ConfAngle = Format(ConfAngle, "0.000")

Dim ConfDistance As Double

ConfDistance = ConfMeasure.GetMinimumDistance(SelEdge1)

ConfDistance = Format(ConfDistance, "0.000")

If ConfAngle <> 90 Or ConfDistance <> 0 Then

MsgBox "選択されたエッジが有効ではないためマクロを中断します。" & vbLf & "四角穴の長辺/短辺エッジを選択して下さい。"

Exit Sub

End If

　
ここでは選択された2つのエッジが90°かつ最短距離が0の場合を四角穴エッジと認識するようにしています。

このとき取得した2つのエッジの角度「ConfAngle」と最短距離「ConfDistance」はFormat関数を使って有効数字を小数点第3位となるように変換しています。

有効数字の変更

ConfAngle = Format(ConfAngle, “0.000”)　’角度
ConfDistance = Format(ConfDistance, “0.000”)　’最短距離

これは「Measurableオブジェクト」で取得した値がかなり細かいものとなってしまうためです。

最終的に取得した値を「If ConfAngle <> 90 Or ConfDistance <> 0 Then」で条件分岐させるのですが、取得した値が「90.0000000054」や「0.00000000013」のようにコンピュータの計算上の誤差による“微小のズレ”によってうまくいかない場合が出てきます。

この問題を解決させるためにCATIAのデフォルト設定と同じ有効数字に変換させているという訳です。