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

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

●プロダクトファイル開いた状態で
　ツリーにぶら下がっているパートをアクティブにしてマクロを実行させたいです。

③穴中心線（座標軸線）作成

　　選択　　　　　　　　　　
　　　円のエッジ選択　（円はボディ＆サーフェスエッジ）
　　　XY方向を決める直線を選択（入力しない場合は主座標の方向）
　　　　↓
　　結果
　　　点　と　円の軸線作成　と　ＸＹ方向線作成

　　・　軸線及びＸＹ方向線は点から両端で作成　（例　始点-10mmm,終点10mm)
　　・　線片側長さはダイアログで数値を入力
（線片側長さは10と入力すれば始点-10mmm,終点10mm　全長は20mm)　　
　　・　作成された線は作成後に履歴により出来れば寸法変更もしたいです。

複数のマクロ案を頂いたので、それぞれ別ページでまとめていきます。
(上記お問い合わせ内容に番号やタイプがついているのは複数案頂いたためです)
そのため、似たようなマクロを別ページでも作成していることもあり、内容がほとんど同じ部分も出てくるので予めご了承ください。

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
    Dim check As Boolean
    
    check = False
    
    filter1 = Array("Edge")
    msg = "エッジ(円)を選択して下さい。"
    
label1:
    
    Status = SEL.SelectElement2(filter1, msg, False)
    If Status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelEdge As Edge
    Set SelEdge = SEL.Item(1).Value
    
    SEL.Clear
    
    'エッジを含むCATPart(PartDocumrnt)を取得
    
    Dim tmp_Obj
    Set tmp_Obj = SelEdge
    
    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 HSF As HybridShapeFactory
    Set HSF = PT.HybridShapeFactory
    
    
    '選択されたエッジが円か確認
    
    Dim SPA As Workbench
    Set SPA = Doc.GetWorkbench("SPAWorkbench")
    
    Dim ConfMeasure
    Set ConfMeasure = SPA.GetMeasurable(SelEdge)
    
    On Error GoTo ErrLabel
        Dim getvalues(2) As Variant
        ConfMeasure.GetCenter getvalues
    On Error GoTo 0
    
    
    filter2 = Array("Line", "RectilinearMonoDimFeatEdge", "RectilinearBiDimFeatEdge", "RectilinearTriDimFeatEdge")
    msg = "直線(軸方向)を選択して下さい。([Esc]キーを押すと絶対座標系を軸方向にします。)"
    
    Status = SEL.SelectElement2(filter2, msg, False)
    If Status = "Normal" Then
    
        Dim SelLine As AnyObject
        Dim RefDir As Reference
        Dim HSDir As HybridShapeDirection
        
        If TypeName(SEL.Item(1).Value) <> "Line" Then
            Set SelLine = SEL.Item(1).Value
            Set HSDir = HSF.AddNewDirection(SelLine)
        Else
            Set SelLine = SEL.Item(1).Value
            Set RefDir = PT.CreateReferenceFromObject(SelLine)
            Set HSDir = HSF.AddNewDirection(RefDir)
        End If
        check = True
    End If
    
    SEL.Clear
    
    
    Dim UserLength As String
    UserLength = InputBox("軸線の長さを入力して下さい。", "長さ入力", 10)
    If UserLength = "" Then
        Exit Sub
    End If
    
    
    Dim HB As HybridBody
    Set HB = PT.HybridBodies.Add
    HB.Name = "穴中心線(座標軸線)"
    
    
    
    '① 選択されたエッジの中心点作成
    
    Dim CtrPoint As Point
    Set CtrPoint = HSF.AddNewPointCenter(SelEdge)
    
    HB.AppendHybridShape CtrPoint
    PT.Update
    
    
    '② 選択されたエッジを通る平面を作成(回転軸取得用)
    
    Dim AxisPlane As Plane
    Set AxisPlane = HSF.AddNewPlane1Curve(SelEdge)
    
    HB.AppendHybridShape AxisPlane
    PT.Update
    
    
    '③ ①を通り②に垂直方向の直線を作成
    
    Dim RefPlane As Reference
    Set RefPlane = PT.CreateReferenceFromObject(AxisPlane)
    
    Dim RefPoint As Reference
    Set RefPoint = PT.CreateReferenceFromObject(CtrPoint)
    
    Dim AxisLine1 As Line
    Set AxisLine1 = HSF.AddNewLineNormal(RefPlane, RefPoint, UserLength, -1 * UserLength, False)
    
    HB.AppendHybridShape AxisLine1
    PT.Update

    
    Dim AxisLine2 As Line
    Dim AxisLine3 As Line
    Dim RefAxisLine1 As Reference
    Dim RefAxisLine2 As Reference
    
    
    If check = True Then   '軸方向が選択された場合
    
    
        '④ ①を通り選択した直線方向の直線を作成

        Set AxisLine2 = HSF.AddNewLinePtDir(RefPoint, HSDir, UserLength, -1 * UserLength, False)
        
        HB.AppendHybridShape AxisLine2
        PT.Update
        
        
        '⑤ ④の直線を②を軸に90deg回転した位置に直線を作成

        Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)
        Set AxisLine3 = HSF.AddNewLineAngle(RefAxisLine2, RefPlane, RefPoint, True, UserLength, -1 * UserLength, 90, False)
        
        HB.AppendHybridShape AxisLine3
        PT.Update
        
        
        'ex ②の平面を非表示
        
        SEL.Add AxisPlane
        VPS.SetShow catVisPropertyNoShowAttr
        SEL.Clear
 

    ElseIf check = False Then   '軸方向が選択されなかった場合
    
    
        '④ ①を通るYZ方向の直線を作成
        
        Dim YZPlane As Plane
        Set YZPlane = PT.OriginElements.PlaneYZ

        Dim RefYZPlane As Reference
        Set RefYZPlane = PT.CreateReferenceFromObject(YZPlane)
        
        Set AxisLine2 = HSF.AddNewLineNormal(RefYZPlane, RefPoint, UserLength, -1 * UserLength, False)
        
        HB.AppendHybridShape AxisLine2
        PT.Update
        
        
        '作成方向の確認
        
        Dim ZXPlane As Plane
        Set ZXPlane = PT.OriginElements.PlaneZX

        Dim RefZXPlane As Reference
        Set RefZXPlane = PT.CreateReferenceFromObject(ZXPlane)
        
        Set ConfMeasure = SPA.GetMeasurable(RefZXPlane)
        
        Dim CheckAngle As Double
        CheckAngle = ConfMeasure.GetAngleBetween(RefPlane)
        
        
        Dim HSExtrude As HybridShapeExtrude
        
        If CheckAngle = 0 Then
        
            '⑤ ④からZX方向への押し出しサーフェス作成
            
            Dim ZXDir As HybridShapeDirection
            Set ZXDir = HSF.AddNewDirection(RefZXPlane)
            
            Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)
            
            Set HSExtrude = HSF.AddNewExtrude(RefAxisLine2, UserLength, UserLength, ZXDir)
            
            HB.AppendHybridShape HSExtrude
            PT.Update
            
        Else
        
            '⑤ ④からXY方向への押し出しサーフェス作成

            Dim XYPlane As Plane
            Set XYPlane = PT.OriginElements.PlaneXY
    
            Dim RefXYPlane As Reference
            Set RefXYPlane = PT.CreateReferenceFromObject(XYPlane)
            
            Dim XYDir As HybridShapeDirection
            Set XYDir = HSF.AddNewDirection(RefXYPlane)
            
            Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)

            Set HSExtrude = HSF.AddNewExtrude(RefAxisLine2, UserLength, UserLength, XYDir)
            
            HB.AppendHybridShape HSExtrude
            PT.Update
        
        End If
        
        
        '⑥ ②と⑤の交差を作成
        
        Dim RefHSExtrude As Reference
        Set RefHSExtrude = PT.CreateReferenceFromObject(HSExtrude)
        
        Dim HSIntersect As HybridShapeIntersection
        Set HSIntersect = HSF.AddNewIntersection(RefPlane, RefHSExtrude)
        
        HB.AppendHybridShape HSIntersect
        PT.Update
        
        
        '⑦ ③と⑥を通る平面を作成
        
        Set RefAxisLine1 = PT.CreateReferenceFromObject(AxisLine1)
        
        Dim RefHSIntersect As Reference
        Set RefHSIntersect = PT.CreateReferenceFromObject(HSIntersect)
        
        Dim Line2Plane As HybridShapePlane2Lines
        Set Line2Plane = HSF.AddNewPlane2Lines(RefAxisLine1, RefHSIntersect)
        
        HB.AppendHybridShape Line2Plane
        PT.Update
        
        
        '⑧ ①を通り⑦に直交方向の直線を作成
        
        Dim RefLine2Plane As Reference
        Set RefLine2Plane = PT.CreateReferenceFromObject(Line2Plane)
        
        Set AxisLine3 = HSF.AddNewLineNormal(RefLine2Plane, RefPoint, UserLength, -1 * UserLength, False)
        
        HB.AppendHybridShape AxisLine3
        PT.Update
        
        
        '⑨ ①を通り⑥方向の直線を作成
        
        Dim HSIntersectDir As HybridShapeDirection
        Set HSIntersectDir = HSF.AddNewDirection(RefHSIntersect)
        
        Dim AxisLine4 As Line
        Set AxisLine4 = HSF.AddNewLinePtDir(RefPoint, HSIntersectDir, UserLength, -1 * UserLength, False)
        
        HB.AppendHybridShape AxisLine4
        PT.Update
        
        
        'ex ②の平面を非表示
        
        With SEL
            .Add AxisPlane
            .Add HSExtrude
            .Add HSIntersect
            
            .Add Line2Plane
            .Add AxisLine2
            VPS.SetShow catVisPropertyNoShowAttr
            .Clear
        End With
    
    End If
    

    Exit Sub

ErrLabel:
    MsgBox "エッジは円を選択してください。"
    SEL.Clear
    Resume label1
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

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

230

231

232

233

234

235

236

237

238

239

240

241

242

243

244

245

246

247

248

249

250

251

252

253

254

255

256

257

258

259

260

261

262

263

264

265

266

267

268

269

270

271

272

273

274

275

276

277

278

279

280

281

282

283

284

285

286

287

288

289

290

291

292

293

294

295

296

297

298

299

300

301

302

303

304

305

306

307

308

309

310

311

312

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

Dim check As Boolean

check = False

filter1 = Array("Edge")

msg = "エッジ(円)を選択して下さい。"

label1:

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

If Status <> "Normal" Then

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

Exit Sub

End If

Dim SelEdge As Edge

Set SelEdge = SEL.Item(1).Value

SEL.Clear

'エッジを含むCATPart(PartDocumrnt)を取得

Dim tmp_Obj

Set tmp_Obj = SelEdge

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 HSF As HybridShapeFactory

Set HSF = PT.HybridShapeFactory

'選択されたエッジが円か確認

Dim SPA As Workbench

Set SPA = Doc.GetWorkbench("SPAWorkbench")

Dim ConfMeasure

Set ConfMeasure = SPA.GetMeasurable(SelEdge)

On Error GoTo ErrLabel

Dim getvalues(2) As Variant

ConfMeasure.GetCenter getvalues

On Error GoTo 0

filter2 = Array("Line", "RectilinearMonoDimFeatEdge", "RectilinearBiDimFeatEdge", "RectilinearTriDimFeatEdge")

msg = "直線(軸方向)を選択して下さい。([Esc]キーを押すと絶対座標系を軸方向にします。)"

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

If Status = "Normal" Then

Dim SelLine As AnyObject

Dim RefDir As Reference

Dim HSDir As HybridShapeDirection

If TypeName(SEL.Item(1).Value) <> "Line" Then

Set SelLine = SEL.Item(1).Value

Set HSDir = HSF.AddNewDirection(SelLine)

Else

Set SelLine = SEL.Item(1).Value

Set RefDir = PT.CreateReferenceFromObject(SelLine)

Set HSDir = HSF.AddNewDirection(RefDir)

End If

check = True

End If

SEL.Clear

Dim UserLength As String

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

If UserLength = "" Then

Exit Sub

End If

Dim HB As HybridBody

Set HB = PT.HybridBodies.Add

HB.Name = "穴中心線(座標軸線)"

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

Dim CtrPoint As Point

Set CtrPoint = HSF.AddNewPointCenter(SelEdge)

HB.AppendHybridShape CtrPoint

PT.Update

'② 選択されたエッジを通る平面を作成(回転軸取得用)

Dim AxisPlane As Plane

Set AxisPlane = HSF.AddNewPlane1Curve(SelEdge)

HB.AppendHybridShape AxisPlane

PT.Update

'③ ①を通り②に垂直方向の直線を作成

Dim RefPlane As Reference

Set RefPlane = PT.CreateReferenceFromObject(AxisPlane)

Dim RefPoint As Reference

Set RefPoint = PT.CreateReferenceFromObject(CtrPoint)

Dim AxisLine1 As Line

Set AxisLine1 = HSF.AddNewLineNormal(RefPlane, RefPoint, UserLength, -1 * UserLength, False)

HB.AppendHybridShape AxisLine1

PT.Update

Dim AxisLine2 As Line

Dim AxisLine3 As Line

Dim RefAxisLine1 As Reference

Dim RefAxisLine2 As Reference

If check = True Then '軸方向が選択された場合

'④ ①を通り選択した直線方向の直線を作成

Set AxisLine2 = HSF.AddNewLinePtDir(RefPoint, HSDir, UserLength, -1 * UserLength, False)

HB.AppendHybridShape AxisLine2

PT.Update

'⑤ ④の直線を②を軸に90deg回転した位置に直線を作成

Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)

Set AxisLine3 = HSF.AddNewLineAngle(RefAxisLine2, RefPlane, RefPoint, True, UserLength, -1 * UserLength, 90, False)

HB.AppendHybridShape AxisLine3

PT.Update

'ex ②の平面を非表示

SEL.Add AxisPlane

VPS.SetShow catVisPropertyNoShowAttr

SEL.Clear

ElseIf check = False Then '軸方向が選択されなかった場合

'④ ①を通るYZ方向の直線を作成

Dim YZPlane As Plane

Set YZPlane = PT.OriginElements.PlaneYZ

Dim RefYZPlane As Reference

Set RefYZPlane = PT.CreateReferenceFromObject(YZPlane)

Set AxisLine2 = HSF.AddNewLineNormal(RefYZPlane, RefPoint, UserLength, -1 * UserLength, False)

HB.AppendHybridShape AxisLine2

PT.Update

'作成方向の確認

Dim ZXPlane As Plane

Set ZXPlane = PT.OriginElements.PlaneZX

Dim RefZXPlane As Reference

Set RefZXPlane = PT.CreateReferenceFromObject(ZXPlane)

Set ConfMeasure = SPA.GetMeasurable(RefZXPlane)

Dim CheckAngle As Double

CheckAngle = ConfMeasure.GetAngleBetween(RefPlane)

Dim HSExtrude As HybridShapeExtrude

If CheckAngle = 0 Then

'⑤ ④からZX方向への押し出しサーフェス作成

Dim ZXDir As HybridShapeDirection

Set ZXDir = HSF.AddNewDirection(RefZXPlane)

Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)

Set HSExtrude = HSF.AddNewExtrude(RefAxisLine2, UserLength, UserLength, ZXDir)

HB.AppendHybridShape HSExtrude

PT.Update

Else

'⑤ ④からXY方向への押し出しサーフェス作成

Dim XYPlane As Plane

Set XYPlane = PT.OriginElements.PlaneXY

Dim RefXYPlane As Reference

Set RefXYPlane = PT.CreateReferenceFromObject(XYPlane)

Dim XYDir As HybridShapeDirection

Set XYDir = HSF.AddNewDirection(RefXYPlane)

Set RefAxisLine2 = PT.CreateReferenceFromObject(AxisLine2)

Set HSExtrude = HSF.AddNewExtrude(RefAxisLine2, UserLength, UserLength, XYDir)

HB.AppendHybridShape HSExtrude

PT.Update

End If

'⑥ ②と⑤の交差を作成

Dim RefHSExtrude As Reference

Set RefHSExtrude = PT.CreateReferenceFromObject(HSExtrude)

Dim HSIntersect As HybridShapeIntersection

Set HSIntersect = HSF.AddNewIntersection(RefPlane, RefHSExtrude)

HB.AppendHybridShape HSIntersect

PT.Update

'⑦ ③と⑥を通る平面を作成

Set RefAxisLine1 = PT.CreateReferenceFromObject(AxisLine1)

Dim RefHSIntersect As Reference

Set RefHSIntersect = PT.CreateReferenceFromObject(HSIntersect)

Dim Line2Plane As HybridShapePlane2Lines

Set Line2Plane = HSF.AddNewPlane2Lines(RefAxisLine1, RefHSIntersect)

HB.AppendHybridShape Line2Plane

PT.Update

'⑧ ①を通り⑦に直交方向の直線を作成

Dim RefLine2Plane As Reference

Set RefLine2Plane = PT.CreateReferenceFromObject(Line2Plane)

Set AxisLine3 = HSF.AddNewLineNormal(RefLine2Plane, RefPoint, UserLength, -1 * UserLength, False)

HB.AppendHybridShape AxisLine3

PT.Update

'⑨ ①を通り⑥方向の直線を作成

Dim HSIntersectDir As HybridShapeDirection

Set HSIntersectDir = HSF.AddNewDirection(RefHSIntersect)

Dim AxisLine4 As Line

Set AxisLine4 = HSF.AddNewLinePtDir(RefPoint, HSIntersectDir, UserLength, -1 * UserLength, False)

HB.AppendHybridShape AxisLine4

PT.Update

'ex ②の平面を非表示

With SEL

.Add AxisPlane

.Add HSExtrude

.Add HSIntersect

.Add Line2Plane

.Add AxisLine2

VPS.SetShow catVisPropertyNoShowAttr

.Clear

End With

End If

Exit Sub

ErrLabel:

MsgBox "エッジは円を選択してください。"

SEL.Clear

Resume label1

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 VPS As VisPropertySet
    Set VPS = SEL.VisProperties
    
    Dim filter1
    Dim filter2
    Dim msg As String
    Dim Status As String
    Dim check As Boolean
    
    check = False
    
    filter1 = Array("Edge")
    msg = "エッジ(円)を選択して下さい。"
    
label1:
    
    Status = SEL.SelectElement2(filter1, msg, False)
    If Status <> "Normal" Then
        MsgBox "キャンセルします。"
        Exit Sub
    End If
    
    Dim SelEdge As Edge
    Set SelEdge = SEL.Item(1).Value
    
    SEL.Clear
    
    'エッジを含むCATPart(PartDocumrnt)を取得
    
    Dim tmp_Obj
    Set tmp_Obj = SelEdge
    
    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 VPS As VisPropertySet

Set VPS = SEL.VisProperties

Dim filter1

Dim filter2

Dim msg As String

Dim Status As String

Dim check As Boolean

check = False

filter1 = Array("Edge")

msg = "エッジ(円)を選択して下さい。"

label1:

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

If Status <> "Normal" Then

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

Exit Sub

End If

Dim SelEdge As Edge

Set SelEdge = SEL.Item(1).Value

SEL.Clear

'エッジを含むCATPart(PartDocumrnt)を取得

Dim tmp_Obj

Set tmp_Obj = SelEdge

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」の部分)

エッジを選択し親オブジェクトを見ていくと
選択したEdge ＜ HybridShapeSurfaceExplicit ＜ Parameters ＜ Part ＜ PartDocument
といった具合に、必ず「PartDocument」が見つかります。

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

ユーザー選択の円を確認

次にユーザーが選択した円が”正円なのか”を確認していきます。
というのも前項で「SelectElement2」を使ってエッジを取得させましたが、その選択フィルターは”Edge”、つまりはエッジで円でなくても選択できるようになってしまっています。

しかし、以降の形状作成の処理では、ユーザーが選択したエッジは正円である必要があります。
([点]コマンドの[円/球/楕円の中心]を使って作成するため)

    Dim SPA As Workbench
    Set SPA = Doc.GetWorkbench("SPAWorkbench")
    
    Dim ConfMeasure
    Set ConfMeasure = SPA.GetMeasurable(SelEdge)
    
    On Error GoTo ErrLabel
        Dim getvalues(2) As Variant
        ConfMeasure.GetCenter getvalues
    On Error GoTo 0

'-----------------------------------------------------------------------
'                                省略
'-----------------------------------------------------------------------

ErrLabel:
    MsgBox "エッジは円を選択してください。"
    SEL.Clear
    Resume label1
End Sub

Dim SPA As Workbench

Set SPA = Doc.GetWorkbench("SPAWorkbench")

Dim ConfMeasure

Set ConfMeasure = SPA.GetMeasurable(SelEdge)

On Error GoTo ErrLabel

Dim getvalues(2) As Variant

ConfMeasure.GetCenter getvalues

On Error GoTo 0

'-----------------------------------------------------------------------

' 省略

'-----------------------------------------------------------------------

ErrLabel:

MsgBox "エッジは円を選択してください。"

SEL.Clear

Resume label1

End Sub

上記のコードでは「Measurableオブジェクト」の「GetCenterメソッド」を使って、ユーザーが選択したエッジの中心点の座標を取得しています。

ここでユーザーが選択したエッジが正円でない場合は、中心座標の取得ができないため「GetCenterメソッド」の行でエラーが発生します。つまり言い換えればここでエラーが発生した場合、ユーザーの選択したエッジは正円でないことがわかります。

ここではエラーが出た場合に「On Error GoTo ErrLabel」を使って「ErrLabel:」に処理を飛ばすようにします。これにより、ユーザーに正円エッジを選択するよう促すことが可能になります。

あとは「ErrLabel:」から前項の「label1:」に処理を飛ばすことで、正円が選択されるまではユーザーの選択フェーズが永遠と続くような仕様になっています。(もちろん[Esc]キーでマクロの中断もできます)

ユーザ－による直線選択(処理の分岐)

エッジが正円と確認出来たら、軸線の方向を指定するための直線をユーザーに選択させます。
ここでお問い合わせの内容を見ると「XY方向を決める直線を選択（入力しない場合は主座標の方向）」とのことなので、ユーザー選択のフェーズで[Esc]キーが押されたら「主座標の方向(絶対座標)」を使うように処理分岐をするようにします。

ここではブーリアン型の変数「check」を使って直線が選択された場合に「True」にすることで、以降の形状作成部分のコードで分岐できるようにしています。

    filter2 = Array("Line", "RectilinearMonoDimFeatEdge", "RectilinearBiDimFeatEdge", "RectilinearTriDimFeatEdge")
    msg = "直線(軸方向)を選択して下さい。([Esc]キーを押すと絶対座標系を軸方向にします。)"
    
    Status = SEL.SelectElement2(filter2, msg, False)
    If Status = "Normal" Then
    
        Dim SelLine As AnyObject
        Dim RefDir As Reference
        Dim HSDir As HybridShapeDirection
        
        If TypeName(SEL.Item(1).Value) <> "Line" Then
            Set SelLine = SEL.Item(1).Value
            Set HSDir = HSF.AddNewDirection(SelLine)
        Else
            Set SelLine = SEL.Item(1).Value
            Set RefDir = PT.CreateReferenceFromObject(SelLine)
            Set HSDir = HSF.AddNewDirection(RefDir)
        End If
        check = True
    End If

filter2 = Array("Line", "RectilinearMonoDimFeatEdge", "RectilinearBiDimFeatEdge", "RectilinearTriDimFeatEdge")

msg = "直線(軸方向)を選択して下さい。([Esc]キーを押すと絶対座標系を軸方向にします。)"

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

If Status = "Normal" Then

Dim SelLine As AnyObject

Dim RefDir As Reference

Dim HSDir As HybridShapeDirection

If TypeName(SEL.Item(1).Value) <> "Line" Then

Set SelLine = SEL.Item(1).Value

Set HSDir = HSF.AddNewDirection(SelLine)

Else

Set SelLine = SEL.Item(1).Value

Set RefDir = PT.CreateReferenceFromObject(SelLine)

Set HSDir = HSF.AddNewDirection(RefDir)

End If

check = True

End If

先のエッジと同じく「SelectElement2」を使って、ユーザーに直線を選択させるようにしますが、ここではフィルターに「Line」だけでなくサブエレメントである「直線エッジ」も選択できるように「RectilinearMonoDimFeatEdge」「RectilinearBiDimFeatEdge」「RectilinearTriDimFeatEdge」もいれています。
(上記3つのオブジェクトについては「CATIA VBAでのサブエレメント(内部要素)」を参照下さい)

ここで1つだけ注意する点があります。
それは、直線(Line)が選択された場合と、直線エッジ(Rectilinear~)が選択された場合に少し処理を変える必要があるという点です。

基本的にCATIAマクロでは形状を作成する時に、その材料となる形状(直線や点などの通常のコマンドで作成できるもの)のオブジェクトはReferenceオブジェクトに変換する必要があります。しかし、その材料がサブエレメントの場合はReferenceオブジェクトに変換する必要がありません。(というよりも変換自体ができません)

今回の場合、初めに「HSDir」という方向を扱うための「HybridShapeDirection」を定義していきます。このオブジェクトの材料となるのはユーザーが選択した直線(もしくは直線エッジ)です。

直線が選択された場合はその直線をReferenceオブジェクトに変換し、そのReferenceオブジェクトを使うことで方向を定義することができます。

            Set SelLine = SEL.Item(1).Value 'ユーザー選択の「直線」を取得
            Set RefDir = PT.CreateReferenceFromObject(SelLine) '「直線」をReferenceオブジェクトに変換
            Set HSDir = HSF.AddNewDirection(RefDir) '方向の定義

Set SelLine = SEL.Item(1).Value 'ユーザー選択の「直線」を取得

Set RefDir = PT.CreateReferenceFromObject(SelLine) '「直線」をReferenceオブジェクトに変換

Set HSDir = HSF.AddNewDirection(RefDir) '方向の定義

　
しかし直線エッジが選択された場合はReferenceオブジェクトに変換できないので、以下のように直線が選択された場合ではReferenceオブジェクトに変換していた部分を端折る必要があります。

            Set SelLine = SEL.Item(1).Value 'ユーザー選択の「直線エッジ」を取得
            Set HSDir = HSF.AddNewDirection(SelLine) '方向の定義

1 2	Set SelLine = SEL.Item(1).Value 'ユーザー選択の「直線エッジ」を取得 Set HSDir = HSF.AddNewDirection(SelLine) '方向の定義

このように「SelectElement系」のメソッドでのフィルターに「形状のオブジェクト」と「サブエレメントのオブジェクト」をまとめる場合は、上記のように処理を分ける必要があるので注意しましょう。

「HSDir」が定義できれば以降で形状作成の処理を行います。
この部分は初めにもいった通り、同じような処理の繰り返しなので割愛します。
(コードのコメント文を見れば何をやっているかある程度理解できると思います)

まとめ

今回は「穴中心線(座標軸線)作成マクロ」についての内容でした。

今回は詳細な履歴の内容も教えて頂いたので、形状作成の流れはそれに従っています。
ただ、CATIAでの形状作成の方法はいくつもあり、これが絶対に正解という訳ではありません。
　
形状作成についてはコードの書き方さえ理解すれば、あとは手動と同じ考え方です。
(形状を作成し、その形状を使って新しい形状を作成していく)
VBAでの形状作成ははじめは少し苦戦するかもしれませんが、理解できればコードすら覚える必要がなくなるほどワンパターンなことに気が付きます。本サイトのサンプルマクロをいくつか見ればパターンがつかめると思うので参考にしてみて下さい。

最後に今回のマクロで学べる、他のマクロでも流用できる部分をまとめると。
コード解説でもあった「CATProduct時に選択されたエッジのあるPartDocumentを取得する方法」と「SelectElement2でのフィルターで形状オブジェクトとサブエレメントオブジェクトがまとまっている場合には処理分岐をさせる」という2点です。

CATIAマクロではどちらも使う場面は出てくると思うので、頭の片隅に入れておきましょう。
　

目次へ戻る