全てのボディーをボリューム化しその和を作成するマクロ｜CATIAマクロの作成方法

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

ワークベンチ:
ジェネレイティブシェイプデザイン

マクロ案:
不特定多数のパートボディを形状ｾｯﾄ内で全て和をして一つにする
1. 不特定多数のパートボディをそれぞれ抽出（点連続）
2. ボリューム化（クロズサーフェス）（Optimizer）
3. 2をそれぞれ和をする

基本的には形状作成を行なっていくだけのマクロなのでコード自体は単純な内容となっています。
今回のような形状作成だけのマクロは「ShapeFactoryオブジェクト」「HybridShapeFactoryオブジェクト」の使い方さえ理解できれば大抵のものは作れるようになるので、「CATIA V5 サンプルマクロ集」にある他のマクロを参考にこれらオブジェクトの使い方を勉強してみて下さい。

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

マクロの機能

今回作成したマクロは
『すべてのボディーをボリューム化し、その”和”を作成するマクロ』です。

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

マクロの機能まとめ・CATPart内にある全てのボディーをボリューム化し、その和(Add)を作成する
・抽出(Extract)、ｸﾛｰｽﾞｻｰﾌｪｽ(Close Surface)、和(Add)の順で作成
・作成した形状はツリー第一階層に新規作成される形状セット内に格納する

サンプルコード

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

Option Explicit

Sub CATMain()

    If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
        MsgBox "CATPartのみ対応のマクロです。"
        Exit Sub
    End If
    
    Dim Doc As PartDocument
    Set Doc = CATIA.ActiveDocument
    
    Dim Pt As Part
    Set Pt = Doc.Part
    
    Dim Sel As Selection
    Set Sel = Doc.Selection
    
  'ﾊｲﾌﾞﾘｯﾄﾞｼｪｲﾌﾟ(ｻｰﾌｪｽ)作成用
    Dim HSF As HybridShapeFactory
    Set HSF = Pt.HybridShapeFactory
    
  'ｼｪｲﾌﾟ(ｿﾘｯﾄﾞ)作成用
    Dim SF As ShapeFactory
    Set SF = Pt.ShapeFactory

  '表示/非表示を切り替える用
    Dim VPS As VisPropertySet
    Set VPS = Sel.VisProperties


    CATIA.RefreshDisplay = False '処理中のアニメーションを省略
    
  '書き出し用形状ｾｯﾄ作成
    Dim HB As HybridBody
    Set HB = Pt.HybridBodies.Add
    
    Dim BodyColl As Collection
    Set BodyColl = New Collection
    
    Sel.Clear
    Sel.Search ("ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ,all") '英語環境の場合は書き換える
    
    Dim i As Integer
    For i = 1 To Sel.Count
        BodyColl.Add Sel.Item(i).Value 'Doc内のﾎﾞﾃﾞｨｰをすべて取得
    Next i
    Sel.Clear
    
    
  '抽出(Extract)を作成
    Dim HSExtractColl As Collection
    Set HSExtractColl = New Collection
    
    For i = 1 To BodyColl.Count

        Dim RefBody As Reference
        Set RefBody = Pt.CreateReferenceFromObject(BodyColl.Item(i))
    
        Dim HSExtract As HybridShapeExtract
        Set HSExtract = HSF.AddNewExtract(RefBody)
        HSExtract.PropagationType = 1
        HSExtract.ComplementaryExtract = False
        HSExtract.IsFederated = False
        
        HB.AppendHybridShape HSExtract
       
      '更新(Update)できない場合は抽出を削除[ErrUpdate]
        On Error GoTo ErrUpdate
            Pt.Update
        On Error GoTo 0
        
        HSExtractColl.Add HSExtract '更新できた抽出のみHSExtractCollの中に格納する
label:
    Next i
    
    
  'ｸﾛｰｽﾞｻｰﾌｪｽ(Close Surface)を作成
    Dim CloseSurfColl As Collection
    Set CloseSurfColl = New Collection
    
    For i = 1 To HSExtractColl.Count
    
        Dim RefSurf As Reference
        Set RefSurf = Pt.CreateReferenceFromObject(HSExtractColl.Item(i))
            
        Dim CloseSurf As CloseSurface
        Set CloseSurf = SF.AddNewVolumeCloseSurface(RefSurf)
        
        CloseSurfColl.Add CloseSurf
        
        Pt.Update
    
    Next i
    

  'ｸﾛｰｽﾞｻｰﾌｪｽの和(Add)を作成
    Dim RefVolume1 As Reference
    Set RefVolume1 = Pt.CreateReferenceFromObject(CloseSurfColl.Item(1))
    
    Dim RefVolume2 As Reference
    Set RefVolume2 = Pt.CreateReferenceFromObject(CloseSurfColl.Item(2))
  
    Dim VolAdd As Add
    Set VolAdd = SF.AddNewVolumeAdd(RefVolume1, RefVolume2, 4#) '[4#]はGSDを表す(ﾊﾟｰﾄﾃﾞｻﾞｲﾝは[0#])
  
    For i = 3 To CloseSurfColl.Count
    
        Set RefVolume1 = Pt.CreateReferenceFromObject(VolAdd)
        Set RefVolume2 = Pt.CreateReferenceFromObject(CloseSurfColl.Item(i))
    
        Set VolAdd = SF.AddNewVolumeAdd(RefVolume1, RefVolume2, 4#)
        
        Pt.Update
        
    Next i
    
    
  '抽出(Extract)をすべて非表示
    Sel.Clear
    For i = 1 To HSExtractColl.Count
        Sel.Add HSExtractColl.Item(i) 'HSExtractCollの中身をすべて選択状態にする
    Next i
    
    VPS.SetShow catVisPropertyNoShowAttr '選択状態のオブジェクトをすべて非表示
    Sel.Clear
    
    
    CATIA.RefreshDisplay = True '処理中のアニメーション省略を元に戻す
    MsgBox "完了"
    
    Exit Sub
    
    
'抽出の更新でエラーが出た場合(=ボディーの中身が空の場合)の処理
ErrUpdate:

    With Sel
        .Clear
        .Add HSExtract
        .Delete
    End With

    Resume label 'エラーが出たHSExtractのみを削除して[label]に戻る

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

Option Explicit

Sub CATMain()

If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then

MsgBox "CATPartのみ対応のマクロです。"

Exit Sub

End If

Dim Doc As PartDocument

Set Doc = CATIA.ActiveDocument

Dim Pt As Part

Set Pt = Doc.Part

Dim Sel As Selection

Set Sel = Doc.Selection

'ﾊｲﾌﾞﾘｯﾄﾞｼｪｲﾌﾟ(ｻｰﾌｪｽ)作成用

Dim HSF As HybridShapeFactory

Set HSF = Pt.HybridShapeFactory

'ｼｪｲﾌﾟ(ｿﾘｯﾄﾞ)作成用

Dim SF As ShapeFactory

Set SF = Pt.ShapeFactory

'表示/非表示を切り替える用

Dim VPS As VisPropertySet

Set VPS = Sel.VisProperties

CATIA.RefreshDisplay = False '処理中のアニメーションを省略

'書き出し用形状ｾｯﾄ作成

Dim HB As HybridBody

Set HB = Pt.HybridBodies.Add

Dim BodyColl As Collection

Set BodyColl = New Collection

Sel.Clear

Sel.Search ("ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ,all") '英語環境の場合は書き換える

Dim i As Integer

For i = 1 To Sel.Count

BodyColl.Add Sel.Item(i).Value 'Doc内のﾎﾞﾃﾞｨｰをすべて取得

Next i

Sel.Clear

'抽出(Extract)を作成

Dim HSExtractColl As Collection

Set HSExtractColl = New Collection

For i = 1 To BodyColl.Count

Dim RefBody As Reference

Set RefBody = Pt.CreateReferenceFromObject(BodyColl.Item(i))

Dim HSExtract As HybridShapeExtract

Set HSExtract = HSF.AddNewExtract(RefBody)

HSExtract.PropagationType = 1

HSExtract.ComplementaryExtract = False

HSExtract.IsFederated = False

HB.AppendHybridShape HSExtract

'更新(Update)できない場合は抽出を削除[ErrUpdate]

On Error GoTo ErrUpdate

Pt.Update

On Error GoTo 0

HSExtractColl.Add HSExtract '更新できた抽出のみHSExtractCollの中に格納する

label:

Next i

'ｸﾛｰｽﾞｻｰﾌｪｽ(Close Surface)を作成

Dim CloseSurfColl As Collection

Set CloseSurfColl = New Collection

For i = 1 To HSExtractColl.Count

Dim RefSurf As Reference

Set RefSurf = Pt.CreateReferenceFromObject(HSExtractColl.Item(i))

Dim CloseSurf As CloseSurface

Set CloseSurf = SF.AddNewVolumeCloseSurface(RefSurf)

CloseSurfColl.Add CloseSurf

Pt.Update

Next i

'ｸﾛｰｽﾞｻｰﾌｪｽの和(Add)を作成

Dim RefVolume1 As Reference

Set RefVolume1 = Pt.CreateReferenceFromObject(CloseSurfColl.Item(1))

Dim RefVolume2 As Reference

Set RefVolume2 = Pt.CreateReferenceFromObject(CloseSurfColl.Item(2))

Dim VolAdd As Add

Set VolAdd = SF.AddNewVolumeAdd(RefVolume1, RefVolume2, 4#) '[4#]はGSDを表す(ﾊﾟｰﾄﾃﾞｻﾞｲﾝは[0#])

For i = 3 To CloseSurfColl.Count

Set RefVolume1 = Pt.CreateReferenceFromObject(VolAdd)

Set RefVolume2 = Pt.CreateReferenceFromObject(CloseSurfColl.Item(i))

Set VolAdd = SF.AddNewVolumeAdd(RefVolume1, RefVolume2, 4#)

Pt.Update

Next i

'抽出(Extract)をすべて非表示

Sel.Clear

For i = 1 To HSExtractColl.Count

Sel.Add HSExtractColl.Item(i) 'HSExtractCollの中身をすべて選択状態にする

Next i

VPS.SetShow catVisPropertyNoShowAttr '選択状態のオブジェクトをすべて非表示

Sel.Clear

CATIA.RefreshDisplay = True '処理中のアニメーション省略を元に戻す

MsgBox "完了"

Exit Sub

'抽出の更新でエラーが出た場合(=ボディーの中身が空の場合)の処理

ErrUpdate:

With Sel

.Clear

.Add HSExtract

.Delete

End With

Resume label 'エラーが出たHSExtractのみを削除して[label]に戻る

End Sub

コード解説

本マクロは基本的に形状を作成するだけのマクロなので、形状作成の部分のコード解説は割愛します。コード内のコメントを見ればどの部分で何を作成しているかは理解できると思うので参考にしてください。

大まかな処理の流れは以下のようになっています。

① CATPart内の[ボディー]を全て取得
② [ボディー]から[抽出]を作成
③ [抽出]から[ｸﾛｰｽﾞｻｰﾌｪｽ]を作成
④ [ｸﾛｰｽﾞｻｰﾌｪｽ]から[和]を作成

ただ、①で取得したボディーの中身が空の場合、②でエラーが発生してしまいます。
そこで以下ではボディーの中身が空だった場合の処理部分を解説していきます。

更新(Update)できない場合は抽出を削除[ErrUpdate]

先にもいった通りボディーの中身が空の場合、抽出作成時にエラーが発生します。
ただ厳密にいうとCATIA VBAでは、形状作成時にエラーが発生するのではなく、作成した形状に対して更新を行って初めてエラーが発生します。(つまりボディーが空だとしても抽出自体はツリーに作成されます)

そこで、本マクロでは形状作成後に「更新」を行い、そこでエラーが発生した場合に「エラーが発生した形状を削除する」という処理を行います。

"]'抽出(Extract)を作成
    Dim HSExtractColl As Collection
    Set HSExtractColl = New Collection
    
    For i = 1 To BodyColl.Count

        Dim RefBody As Reference
        Set RefBody = Pt.CreateReferenceFromObject(BodyColl.Item(i))
    
        Dim HSExtract As HybridShapeExtract
        Set HSExtract = HSF.AddNewExtract(RefBody)
        HSExtract.PropagationType = 1
        HSExtract.ComplementaryExtract = False
        HSExtract.IsFederated = False
        
        HB.AppendHybridShape HSExtract
       
      '更新(Update)できない場合は抽出を削除[ErrUpdate]
        On Error GoTo ErrUpdate
            Pt.Update
        On Error GoTo 0
        
        HSExtractColl.Add HSExtract '更新できた抽出のみHSExtractCollの中に格納する
label:
    Next I

'──────────────────────────────────────────────────────────────────────────────────
　　　　　　　　　　　　　　　　　　　　　　　'中略
'──────────────────────────────────────────────────────────────────────────────────


'抽出の更新でエラーが出た場合(=ボディーの中身が空の場合)の処理
ErrUpdate:

    With Sel
        .Clear
        .Add HSExtract
        .Delete
    End With

    Resume label 'エラーが出たHSExtractのみを削除して[label]に戻る

End Sub