Productから作成したCATPartを元のProduct構成に戻すマクロ｜CATIAマクロの作成方法

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

⑤プロダクトを履歴なしのプロダクトを作成
　　準備
　　「プロダクトからcatpartを生成」で出力したパートを作成
　　　↓　　
　　マクロ実行＆結果　
　　　用意したパートでボディや形状セット名の￥を利用してプロダクト化へ

はじめに言っておくと今回のマクロでは完全に同じProduct構成を再現することはできません。
これは準備として生成するCATPartが「インスタンス名」で出力されることが深く関係してきます。
詳しくは本文で解説していきますが、この前提はあらかじめ理解しておいてください。

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

マクロの機能

今回作成したマクロは
『Productから作成したCATPartを元のProduct構成を再現するマクロ』です。

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

マクロの機能まとめ・[ツール]>[ﾌﾟﾛﾀﾞｸﾄからCATPartを生成]で作成されたCATPart内で実行可能
(Partの名称に「_AllCATPart」と入っていることで判断する)
・形状セット/ボディーの名称から同一のProduct構成を再現する
・同Product/Partが複数使われている場合はうまく実行できないので注意

今回のマクロでは、形状セット/ボディーの名称からProductやPartの名前を取得して、同名のProductやPartを作成するという流れの処理を行ないます。

ここで問題なのが、[ﾌﾟﾛﾀﾞｸﾄからCATPartを生成]で作成された形状セット/ボディーの名称はインスタンス名だけという点です。インスタンス名は同一名称になることはなく、かつユーザーが好きなように変更することができます。

これにより元のProduct構成を再現することが難しいため、本マクロでは同Product/Partが複数使われている場合の処理は未対応になっています。(インスタンスもとのプロダクトのパーツ番号が取得できないと、複数のプロダクトのオリジナルが同一のプロダクトかを確認することができないことが大きな原因の1つです)

また簡単なProduct構成でしか処理の結果を確認できていないので、膨大なProductではもしかしたらうまくいかない可能性があるのであらかじめご了承ください。

サンプルコード

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

Option Explicit
Option Base 1
'―――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
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
    
    
'「ﾌﾟﾛﾀﾞｸﾄからCATPartを生成」で作成されたCATPartかを判定

    Dim NameCheck As Integer
    NameCheck = InStr(1, PT.Name, "_AllCATPart")

    If NameCheck = 0 Then
        MsgBox "プロダクトから生成されたCATPart専用マクロです。"
        Exit Sub
    End If
    
    
    Dim ExportPro As ProductDocument
    Set ExportPro = CATIA.Documents.Add("Product")

    Dim RootPro As Product
    Set RootPro = ExportPro.Product

    Dim RootPros As Products
    Set RootPros = RootPro.Products

    On Error Resume Next
        RootPro.PartNumber = Replace(PT.Name, "_AllCATPart", "")
    On Error GoTo 0
    
'出力された形状ｾｯﾄとﾎﾞﾃﾞｨｰをすべて取得
    
    Dim HBCount As Integer
    
    Dim SEL As Selection
    Set SEL = Doc.Selection
    
    SEL.Search ("ｼﾞｪﾈﾚｰﾃｨﾌﾞ･ｼｪｲﾌﾟ･ﾃﾞｻﾞｲﾝ.形状ｾｯﾄ,all")
    
    Dim SELColl As Collection
    Set SELColl = New Collection
    
    HBCount = SEL.Count '形状ｾｯﾄの数を取得
    
    Dim i As Integer
    For i = 1 To SEL.Count
        SELColl.Add SEL.Item(i).Value
    Next i
    
    SEL.Clear
    SEL.Search ("ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ,all")
    SEL.Remove 1 'ﾊﾟｰﾂ・ﾎﾞﾃﾞｨｰを選択から除去
    
    For i = 1 To SEL.Count
        SELColl.Add SEL.Item(i).Value
    Next i
    
    SEL.Clear


'ループで新規Productに出力

    CATIA.RefreshDisplay = False
    
    Dim j As Integer
    Dim SepCnt As Integer
    Dim CreateProNameArray() As String
    Dim ProNameArray() As String
    Dim cnt As Integer
    Dim ProNameCheck As Boolean
    
    Dim NewPros 'As Products
    Dim NewPro 'As Product
    Dim NewPartDoc As PartDocument
    Dim NewPart As Part
    Dim NewPartHBs As HybridBodies
    Dim NewPartBodies As Bodies
    
    ReDim CreateProNameArray(1)
    
    For i = 1 To SELColl.Count
    
        Set NewPros = RootPros
    
        '[\]の個数をカウント
        SepCnt = Len(SELColl.Item(i).Name) - Len(Replace(SELColl.Item(i).Name, "\", ""))
        
        ProNameArray = Split(SELColl.Item(i).Name, "\")
            
        For j = 0 To UBound(ProNameArray)
            DoEvents
            cnt = 1
            ProNameCheck = False
            Do
                DoEvents
                If ProNameArray(j) = CreateProNameArray(cnt) Then
                    ProNameCheck = True
                End If
                
                If cnt = UBound(CreateProNameArray) Then
                    Exit Do
                End If
                
                cnt = cnt + 1
            Loop
            
            If j = UBound(ProNameArray) - 1 Then  'Part処理
            
                If ProNameCheck = False Then
                
                    Set NewPro = NewPros.AddNewComponent("Part", "")
                    On Error Resume Next
                        NewPro.Name = ProNameArray(j)
                        NewPro.PartNumber = ProNameArray(j)
                    On Error GoTo 0
                    Set NewPartDoc = NewPro.ReferenceProduct.Parent
    
                    CreateProNameArray(UBound(CreateProNameArray)) = ProNameArray(j)
                    ReDim Preserve CreateProNameArray(UBound(CreateProNameArray) + 1)
                Else
                
                    On Error Resume Next
                        Set NewPro = NewPros.Item(ProNameArray(j))
                        Set NewPartDoc = NewPro.ReferenceProduct.Parent
                    On Error GoTo 0
                        
                End If
            
            ElseIf j = UBound(ProNameArray) Then  '形状ｾｯﾄ/ﾎﾞﾃﾞｨｰ処理
            
                If ProNameCheck = False Then
                
                    Set NewPart = NewPartDoc.Part
                    Set NewPartHBs = NewPart.HybridBodies
                    Set NewPartBodies = NewPart.Bodies

                    SEL.Add SELColl(i)
                    SEL.Copy
                    SEL.Clear

                    Set SEL = ExportPro.Selection 'SelectionをCATProductに変更
                    SEL.Add NewPart
                    SEL.Paste
                    SEL.Clear
                    
                    On Error Resume Next
                        NameCheck = InStr(1, NewPartHBs.Item(NewPartHBs.Count).Name, "\")
                        
                        If NameCheck <> 0 Then
                            NewPartHBs.Item(NewPartHBs.Count).Name = ProNameArray(j)
                        End If
                        
                        NameCheck = InStr(1, NewPartBodies.Item(NewPartBodies.Count).Name, "\")
                        
                        If NameCheck <> 0 Then
                            NewPartBodies.Item(NewPartBodies.Count).Name = ProNameArray(j)
                        End If
                    On Error GoTo 0

                    NewPart.Update
                    Set SEL = Doc.Selection 'SelectionをCATPartに変更
                
                End If
            
            Else  'Product処理
            
                If ProNameCheck = False Then
                
                    Set NewPro = NewPros.AddNewComponent("Product", "")
                    On Error Resume Next
                        NewPro.Name = ProNameArray(j)
                        NewPro.PartNumber = ProNameArray(j)
                    On Error GoTo 0
                    Set NewPros = NewPro.Products
    
                    CreateProNameArray(UBound(CreateProNameArray)) = ProNameArray(j)
                    ReDim Preserve CreateProNameArray(UBound(CreateProNameArray) + 1)
                
                Else
                    
                    On Error Resume Next
                        Set NewPro = NewPros.Item(ProNameArray(j))
                        Set NewPros = NewPro.Products
                    On Error GoTo 0
                    
                End If
                    
            End If
            
        Next j

        Set NewPros = RootPros
        
    Next i
    
    CATIA.RefreshDisplay = True
            
    MsgBox "完了しました。"

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

Option Explicit

Option Base 1

'―――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――

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

'「ﾌﾟﾛﾀﾞｸﾄからCATPartを生成」で作成されたCATPartかを判定

Dim NameCheck As Integer

NameCheck = InStr(1, PT.Name, "_AllCATPart")

If NameCheck = 0 Then

MsgBox "プロダクトから生成されたCATPart専用マクロです。"

Exit Sub

End If

Dim ExportPro As ProductDocument

Set ExportPro = CATIA.Documents.Add("Product")

Dim RootPro As Product

Set RootPro = ExportPro.Product

Dim RootPros As Products

Set RootPros = RootPro.Products

On Error Resume Next

RootPro.PartNumber = Replace(PT.Name, "_AllCATPart", "")

On Error GoTo 0

'出力された形状ｾｯﾄとﾎﾞﾃﾞｨｰをすべて取得

Dim HBCount As Integer

Dim SEL As Selection

Set SEL = Doc.Selection

SEL.Search ("ｼﾞｪﾈﾚｰﾃｨﾌﾞ･ｼｪｲﾌﾟ･ﾃﾞｻﾞｲﾝ.形状ｾｯﾄ,all")

Dim SELColl As Collection

Set SELColl = New Collection

HBCount = SEL.Count '形状ｾｯﾄの数を取得

Dim i As Integer

For i = 1 To SEL.Count

SELColl.Add SEL.Item(i).Value

Next i

SEL.Clear

SEL.Search ("ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ,all")

SEL.Remove 1 'ﾊﾟｰﾂ・ﾎﾞﾃﾞｨｰを選択から除去

For i = 1 To SEL.Count

SELColl.Add SEL.Item(i).Value

Next i

SEL.Clear

'ループで新規Productに出力

CATIA.RefreshDisplay = False

Dim j As Integer

Dim SepCnt As Integer

Dim CreateProNameArray() As String

Dim ProNameArray() As String

Dim cnt As Integer

Dim ProNameCheck As Boolean

Dim NewPros 'As Products

Dim NewPro 'As Product

Dim NewPartDoc As PartDocument

Dim NewPart As Part

Dim NewPartHBs As HybridBodies

Dim NewPartBodies As Bodies

ReDim CreateProNameArray(1)

For i = 1 To SELColl.Count

Set NewPros = RootPros

'[\]の個数をカウント

SepCnt = Len(SELColl.Item(i).Name) - Len(Replace(SELColl.Item(i).Name, "\", ""))

ProNameArray = Split(SELColl.Item(i).Name, "\")

For j = 0 To UBound(ProNameArray)

DoEvents

cnt = 1

ProNameCheck = False

DoEvents

If ProNameArray(j) = CreateProNameArray(cnt) Then

ProNameCheck = True

End If

If cnt = UBound(CreateProNameArray) Then

Exit Do

End If

cnt = cnt + 1

Loop

If j = UBound(ProNameArray) - 1 Then 'Part処理

If ProNameCheck = False Then

Set NewPro = NewPros.AddNewComponent("Part", "")

On Error Resume Next

NewPro.Name = ProNameArray(j)

NewPro.PartNumber = ProNameArray(j)

On Error GoTo 0

Set NewPartDoc = NewPro.ReferenceProduct.Parent

CreateProNameArray(UBound(CreateProNameArray)) = ProNameArray(j)

ReDim Preserve CreateProNameArray(UBound(CreateProNameArray) + 1)

Else

On Error Resume Next

Set NewPro = NewPros.Item(ProNameArray(j))

Set NewPartDoc = NewPro.ReferenceProduct.Parent

On Error GoTo 0

End If

ElseIf j = UBound(ProNameArray) Then '形状ｾｯﾄ/ﾎﾞﾃﾞｨｰ処理

If ProNameCheck = False Then

Set NewPart = NewPartDoc.Part

Set NewPartHBs = NewPart.HybridBodies

Set NewPartBodies = NewPart.Bodies

SEL.Add SELColl(i)

SEL.Copy

SEL.Clear

Set SEL = ExportPro.Selection 'SelectionをCATProductに変更

SEL.Add NewPart

SEL.Paste

SEL.Clear

On Error Resume Next

NameCheck = InStr(1, NewPartHBs.Item(NewPartHBs.Count).Name, "\")

If NameCheck <> 0 Then

NewPartHBs.Item(NewPartHBs.Count).Name = ProNameArray(j)

End If

NameCheck = InStr(1, NewPartBodies.Item(NewPartBodies.Count).Name, "\")

If NameCheck <> 0 Then

NewPartBodies.Item(NewPartBodies.Count).Name = ProNameArray(j)

End If

On Error GoTo 0

NewPart.Update

Set SEL = Doc.Selection 'SelectionをCATPartに変更

End If

Else 'Product処理

If ProNameCheck = False Then

Set NewPro = NewPros.AddNewComponent("Product", "")

On Error Resume Next

NewPro.Name = ProNameArray(j)

NewPro.PartNumber = ProNameArray(j)

On Error GoTo 0

Set NewPros = NewPro.Products

CreateProNameArray(UBound(CreateProNameArray)) = ProNameArray(j)

ReDim Preserve CreateProNameArray(UBound(CreateProNameArray) + 1)

Else

On Error Resume Next

Set NewPro = NewPros.Item(ProNameArray(j))

Set NewPros = NewPro.Products

On Error GoTo 0

End If

Next j

Set NewPros = RootPros

Next i

CATIA.RefreshDisplay = True

MsgBox "完了しました。"

End Sub

簡単な実行確認はしていますが、エラーの発生や意図しない動きをする可能性があります。

コード解説

ここでは上記マクロコードのいくつかの部分を抜粋して解説していきます。
　

ドキュメントの定義

    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

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

まず、はじめにアクティブドキュメントの定義をします。
今回のマクロはCATPartでのみ有効なものなので、アクティブドキュメントがCATPart以外の場合はTypeName関数を使った条件分岐でマクロを終了するようにしています。

条件分岐の先、つまりはアクティブドキュメントがCATPartの場合は変数「Doc」にアクティブドキュメントを代入します。あわせて変数「PT」にはアクティブドキュメントのPartを代入します。

[ﾌﾟﾛﾀﾞｸﾄからCATPartを生成]で作成されたCATPartかを判定

    Dim NameCheck As Integer
    NameCheck = InStr(1, PT.Name, "_AllCATPart")

    If NameCheck = 0 Then
        MsgBox "プロダクトから生成されたCATPart専用マクロです。"
        Exit Sub
    End If

Dim NameCheck As Integer

NameCheck = InStr(1, PT.Name, "_AllCATPart")

If NameCheck = 0 Then

MsgBox "プロダクトから生成されたCATPart専用マクロです。"

Exit Sub

End If

つぎにアクティブドキュメントが[ﾌﾟﾛﾀﾞｸﾄからCATPartを生成]で作成されたCATPartかを判定します。
ここではPartの名称に「_AllCATPart」の文字列が含めれている場合に[ﾌﾟﾛﾀﾞｸﾄからCATPartを生成]で作成されたCATPartであると判断します。

InStr関数を使うことで「指定した文字列A」に対して「指定した文字列B」が何番目の文字かを取得することができます。文字列が含まれない場合は「0」が返されるので、ここでは「NameCheck = 0」の場合にはマクロを中断するようにしています。
　

新規Productを作成

    Dim ExportPro As ProductDocument
    Set ExportPro = CATIA.Documents.Add("Product")

    Dim RootPro As Product
    Set RootPro = ExportPro.Product

    Dim RootPros As Products
    Set RootPros = RootPro.Products

    On Error Resume Next
        RootPro.PartNumber = Replace(PT.Name, "_AllCATPart", "")
    On Error GoTo 0

Dim ExportPro As ProductDocument

Set ExportPro = CATIA.Documents.Add("Product")

Dim RootPro As Product

Set RootPro = ExportPro.Product

Dim RootPros As Products

Set RootPros = RootPro.Products

On Error Resume Next

RootPro.PartNumber = Replace(PT.Name, "_AllCATPart", "")

On Error GoTo 0

つぎに新規Productを作成します。(Productの作成方法は「Documentsコレクション」を参照)

新規Productを作成したら、あわせて一番親のProduct(RootProductともいう)とそのProductsコレクションを定義しておきます。これらは以降で新規CATProduct/CATPartを作成していくときに使います。

作成したProductの名前は、CATPartの名称から「_All CATPart」を取り除いたものにします。
(Replace関数を使い「_All CATPart」という文字列を「」に変換すれば取り除くことが可能)

今回は、このReplaceでなぜかエラーが発生してしまったので「On Error Resume Next」で無視させています。(「On Error Resume Next」を消しても問題なく実行できる場合は「On Error〜」の2行は削除して問題ありません)
　

出力された形状ｾｯﾄとﾎﾞﾃﾞｨｰをすべて取得

    Dim HBCount As Integer
    
    Dim SEL As Selection
    Set SEL = Doc.Selection
    
    SEL.Search ("ｼﾞｪﾈﾚｰﾃｨﾌﾞ･ｼｪｲﾌﾟ･ﾃﾞｻﾞｲﾝ.形状ｾｯﾄ,all")
    
    Dim SELColl As Collection
    Set SELColl = New Collection
    
    HBCount = SEL.Count '形状ｾｯﾄの数を取得
    
    Dim i As Integer
    For i = 1 To SEL.Count
        SELColl.Add SEL.Item(i).Value
    Next i
    
    SEL.Clear
    SEL.Search ("ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ,all")
    SEL.Remove 1 'ﾊﾟｰﾂ・ﾎﾞﾃﾞｨｰを選択から除去
    
    For i = 1 To SEL.Count
        SELColl.Add SEL.Item(i).Value
    Next i
    
    SEL.Clear

Dim HBCount As Integer

Dim SEL As Selection

Set SEL = Doc.Selection

SEL.Search ("ｼﾞｪﾈﾚｰﾃｨﾌﾞ･ｼｪｲﾌﾟ･ﾃﾞｻﾞｲﾝ.形状ｾｯﾄ,all")

Dim SELColl As Collection

Set SELColl = New Collection

HBCount = SEL.Count '形状ｾｯﾄの数を取得

Dim i As Integer

For i = 1 To SEL.Count

SELColl.Add SEL.Item(i).Value

Next i

SEL.Clear

SEL.Search ("ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ,all")

SEL.Remove 1 'ﾊﾟｰﾂ・ﾎﾞﾃﾞｨｰを選択から除去

For i = 1 To SEL.Count

SELColl.Add SEL.Item(i).Value

Next i

SEL.Clear

つぎにCATPart内の全ての形状セットとボディーを取得し、それぞれ同一のコレクション「SELColl」に格納しておきます。これにより「SELColl.Item(x)」で任意の形状セット/ボディーをいつでも取り出すことが可能になります。

ここでは①形状セット→②ボディーの順に「SELColl」に格納していくので
「SELColl.Item(1) 〜 SELColl.Item(HBCount)」の範囲が形状セット
「SELColl.Item(HBCount + 1) 〜 SELColl.Item(SELColl.Count)」の範囲がボディー
のように表すことができます。

以降ではこの「SELColl」に入っている1番目の形状セットから順に1つずつループで処理を行います。
　

ループで新規Productに出力

この部分の処理は1から説明すると非常に長くなるので、大まかな概要だけ説明していきます。

ここでは前項で取得した形状セットとボディーの名前を取得しProduct構成を再現していきます。

形状セット/ボディーの名前は
「Product2.1¥Product6.1¥Part6.1¥形状ｾｯﾄ.1」
のように親のProductから順に「¥」マークで区切られてることがわかります。

この文字列を「Split関数」を使って「¥」マーク部分で分割します。
分割した文字列は「ProNameArray」という配列に格納します。
たとえば先ほどの文字列の場合は”Product2.1″、”Product6.1″、”Part6.1″、”形状ｾｯﾄ.1″という4つの文字列が配列に格納されます。

あとはこの配列内の要素数だけループで処理を行っていきます。
ループ内では「Product」「Part」「形状セット/ボディー」の3つに分けて処理をします。
たとえば前と同じ文字列の場合はProduct2.1とProduct6.1が「Product」、Part6.1が「Part」、形状ｾｯﾄ.1が「形状セット/ボディー」と振り分けることができます。

それぞれの処理の内容は以下のとおりです。

Product → その名前で新規Productを作成
Part → その名前で新規Partを作成
形状セット/ボディー → ベースのCATPartからコピペ

これを「ProNameArray」に入っている最初の要素から順に行なっていきます。
たとえばこれまでの文字列の場合「①Product2.1②Product6.1③Part6.1④形状ｾｯﾄ.1」の順で処理を行なっていきます。よって以下のような処理が行われます。

① 「Product2.1」という名前のProductを作成
② ①の直下に「Product6.1」という名前のProductを作成
③ ②の直下に「Part6.1」という名前のPartを作成
④ ③にベースのCATPartから該当の形状セット/ボディーをコピペ

　
上記で基本的な部分の流れはできますが、同じProduct内に複数のProduct/Partがある場合は上記の処理ではできません。(上記の処理では毎回新規Productを作成するので、同名のProductが作成され別物扱いされてしまうため)

そこで、作成するProductと同じ名前のProductが既に存在する場合は、新規Productを作成せずにそのProductを再利用するような処理を行います。

そのために作成したProductの名前を全て「CreateProNameArray」という配列に格納していきます。これにより既にProductを作成しているか、作成していないのかを確認することができます。