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

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

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

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

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

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

まとめ

今回は「長穴中心線(座標軸線)作成マクロ」についての内容でした。
基本的には以前作成した「穴中心線(座標軸線)作成マクロ」と同じようなコードとなっています。

VBAでの形状作成は「HybridShapeFactory」(GSDの場合)を使って、ほとんど同じことの繰り返しなのでコードが長くなってもやっていること自体は単純です。今回のマクロもユーザーに2つの直線エッジを選択させ、そのエッジを使って形状作成をしているだけです。

VBAで形状作成を作成したい場合は「HybridShapeFactory」(GSDの場合)もしくは「ShapeFactory」(パートデザインの場合)さえ押さえておけば問題ありません。
　

目次へ戻る

CATIAマクロを本気で勉強するなら

Vb Scripting for Catia V5: How to Program Catia Macros

created by Rinker

CATIA V5: Macro Programming with Visual Basic Script

created by Rinker

McGraw-Hill Education

2020年9月15日2024年8月26日CATIA, CATIAマクロ

Posted by Lic

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

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

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

マクロの機能

サンプルコード

まとめ

icon-book CATIAマクロを本気で勉強するなら

CATIAマクロを本気で勉強するなら