ボディー名と形状セット名をCSVファイルそして出力するマクロ2｜CATIAマクロの作成方法

以前「ボディー名と形状セット名をCSVファイルそして出力するマクロ」のサンプルコードを紹介しましたが、お問い合わせ頂いた方から「ボディ名と形状セット名をツリー順に並べたい」とご連絡いただきました。

というわけで、以前のサンプルコードを少し書き換えて「ツリー第1階層にあるボディーと形状セットの名称をツリー順でCSVファイルに出力するマクロ」の紹介していきます。

基本的な処理内容は以前のものと変わっていないので、今回は追加した分のコードのみの解説をしていきます。全体の処理内容については前回記事を参考にして下さい。

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

マクロの機能

今回作成したのはツリー第1階層にあるボディー/形状セット名を“ツリー順で”CSVファイルに出力するマクロです。具体的な機能は以下のとおりです。

マクロの機能まとめ・ツリー第1階層にあるボディーと形状セットの名前をツリー順でCSVファイルとして出力する
・ファイル名はPart名 (※同名のファイルがある場合は上書きの確認をする)
・ボディー名称、形状セット名称の順で出力
・出力後はCSVファイルを開く

サンプルコード

マクロのコードは以下のとおりです。
コード内の保存場所となる「saveDir」の中身は自身のものに書き換える必要があります。

Option Explicit
Sub CATMain()

 'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義
    If TypeName(CATIA.ActiveDocument) <> "PartDocument" Then
       MsgBox "このマクロはPartDocument専用です。" & vbLf & _
              "CATPartに切り替えて実行してください。"
       Exit Sub
    End If
    
    Dim doc As PartDocument
    Set doc = CATIA.ActiveDocument
 
 'Part定義
    Dim pt As Part
    Set pt = doc.Part
    
 'Selection定義
    Dim sel As Selection
    Set sel = doc.Selection
    sel.Clear
        
 'ﾄﾞｷｭﾒﾝﾄ内の全てのﾎﾞﾃﾞｨｰ/形状ｾｯﾄを取得
    Dim i As Integer
    Dim objs As Collection
    Set objs = New Collection
    
    sel.Search ("(ｼﾞｪﾈﾚｰﾃｨﾌﾞ･ｼｪｲﾌﾟ･ﾃﾞｻﾞｲﾝ.形状ｾｯﾄ + ﾊﾟｰﾄ･ﾃﾞｻﾞｲﾝ.ﾎﾞﾃﾞｨｰ),all")
    
    For i = 1 To sel.Count
        objs.Add sel.Item(i).Value
    Next i
    sel.Clear
    
 'ツリー第1階層のみの名称を取得
    Dim names() As String       'ﾎﾞﾃﾞｨｰ/形状ｾｯﾄ名格納用配列
    names = Get1LvNames(objs)   'ﾂﾘｰ第1階層のﾎﾞﾃﾞｨｰ/形状ｾｯﾄ名を取得
    
 'csv出力用文字列の作成
    Dim csv As String
    csv = names(1)
    
    For i = 2 To UBound(names)
        csv = csv + "," + names(i)      'ｶﾝﾏ + ﾎﾞﾃﾞｨｰ/形状ｾｯﾄ名を後ろに追加
    Next i

 'csv出力
    Dim fs 'As FileSystem
    Set fs = CATIA.FileSystem
    
    Dim saveDir As String
    saveDir = "C:\Users\ﾕｰｻﾞｰ名\Desktop" '保存ﾃﾞｨﾚｸﾄﾘ(ﾌｫﾙﾀﾞ)の指定
    
    Dim fileName As String
    fileName = pt.name + ".csv"            '保存ﾌｧｲﾙ名の指定
    
    Dim savePath As String
    savePath = saveDir + "\" + fileName　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　'"'

    If fs.FileExists(savePath) Then
        Dim res As Integer
        res = MsgBox("同名のファイルが存在します。上書きしますか?", vbYesNo + vbQuestion)
        If res = vbNo Then Exit Sub
    End If

    Dim csvFile As file
    Set csvFile = fs.CreateFile(savePath, True)

    Dim ts As TextStream
    Set ts = csvFile.OpenAsTextStream("ForWriting")

    ts.Write (csv)
    ts.Close

    Set fs = Nothing
    Set ts = Nothing

 '出力したcsvファイルを開く
    Shell "C:\Windows\Explorer.exe " & savePath, vbNormalFocus

End Sub
'―――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――――
Function Get1LvNames(ByVal objs As Collection) As String()

    Dim names() As String
    ReDim names(objs.Count)

    Dim pt As Part
    Set pt = CATIA.ActiveDocument.Part
    
    Dim obj As Object
    Dim b As Body
    Dim hb As HybridBody
    Dim chk As Boolean
    Dim i As Integer: i = 1
    
 'objs内のﾂﾘｰ第1階層のﾎﾞﾃﾞｨｰ/形状ｾｯﾄの名称のみを取得
    For Each obj In objs
        chk = False
        
        For Each b In pt.Bodies
            If obj.name = b.name Then chk = True
        Next b
        For Each hb In pt.HybridBodies
            If obj.name = hb.name Then chk = True
        Next hb
        
        If chk = True Then
            names(i) = obj.name
            i = i + 1
        End If
    Next obj
    
 '空の要素を削除
    For i = 1 To UBound(names)
        If names(i) = "" Then
            ReDim Preserve names(i - 1)
            Exit For
        End If
    Next i
    
    Get1LvNames = names()
    
End Function

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

Option Explicit

Sub CATMain()

'ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ定義

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

MsgBox "このマクロはPartDocument専用です。" & vbLf & _

"CATPartに切り替えて実行してください。"

Exit Sub

End If

Dim doc As PartDocument

Set doc = CATIA.ActiveDocument

'Part定義

Dim pt As Part

Set pt = doc.Part

'Selection定義

Dim sel As Selection

Set sel = doc.Selection

sel.Clear

'ﾄﾞｷｭﾒﾝﾄ内の全てのﾎﾞﾃﾞｨｰ/形状ｾｯﾄを取得

Dim i As Integer

Dim objs As Collection

Set objs = New Collection

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

For i = 1 To sel.Count

objs.Add sel.Item(i).Value

Next i

sel.Clear

'ツリー第1階層のみの名称を取得

Dim names() As String 'ﾎﾞﾃﾞｨｰ/形状ｾｯﾄ名格納用配列

names = Get1LvNames(objs) 'ﾂﾘｰ第1階層のﾎﾞﾃﾞｨｰ/形状ｾｯﾄ名を取得

'csv出力用文字列の作成

Dim csv As String

csv = names(1)

For i = 2 To UBound(names)

csv = csv + "," + names(i) 'ｶﾝﾏ + ﾎﾞﾃﾞｨｰ/形状ｾｯﾄ名を後ろに追加

Next i

'csv出力

Dim fs 'As FileSystem

Set fs = CATIA.FileSystem

Dim saveDir As String

saveDir = "C:\Users\ﾕｰｻﾞｰ名\Desktop" '保存ﾃﾞｨﾚｸﾄﾘ(ﾌｫﾙﾀﾞ)の指定

Dim fileName As String

fileName = pt.name + ".csv" '保存ﾌｧｲﾙ名の指定

Dim savePath As String

savePath = saveDir + "\" + fileName　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　'"'

If fs.FileExists(savePath) Then

Dim res As Integer

res = MsgBox("同名のファイルが存在します。上書きしますか?", vbYesNo + vbQuestion)

If res = vbNo Then Exit Sub

End If

Dim csvFile As file

Set csvFile = fs.CreateFile(savePath, True)

Dim ts As TextStream

Set ts = csvFile.OpenAsTextStream("ForWriting")

ts.Write (csv)

ts.Close

Set fs = Nothing

Set ts = Nothing

'出力したcsvファイルを開く

Shell "C:\Windows\Explorer.exe " & savePath, vbNormalFocus

End Sub

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

Function Get1LvNames(ByVal objs As Collection) As String()

Dim names() As String

ReDim names(objs.Count)

Dim pt As Part

Set pt = CATIA.ActiveDocument.Part

Dim obj As Object

Dim b As Body

Dim hb As HybridBody

Dim chk As Boolean

Dim i As Integer: i = 1

'objs内のﾂﾘｰ第1階層のﾎﾞﾃﾞｨｰ/形状ｾｯﾄの名称のみを取得

For Each obj In objs

chk = False

For Each b In pt.Bodies

If obj.name = b.name Then chk = True

Next b

For Each hb In pt.HybridBodies

If obj.name = hb.name Then chk = True

Next hb

If chk = True Then

names(i) = obj.name

i = i + 1

End If

Next obj

'空の要素を削除

For i = 1 To UBound(names)

If names(i) = "" Then

ReDim Preserve names(i - 1)

Exit For

End If

Next i

Get1LvNames = names()

End Function

コード解説

基本的には前回のサンプルコードと変わりありません。
今回は「Get1LvNames」という、入力されたボディーと形状セットの入ったコレクションから、ツリー第1階層のみを選別しその名称の入った配列を返す関数を作成しました。

以下では「Get1LvNames」の処理内容を解説していきます。

Get1LvNames関数

Function Get1LvNames(ByVal objs As Collection) As String()

    Dim names() As String
    ReDim names(objs.Count)

    Dim pt As Part
    Set pt = CATIA.ActiveDocument.Part
    
    Dim obj As Object
    Dim b As Body
    Dim hb As HybridBody
    Dim chk As Boolean
    Dim i As Integer: i = 1
    
 'objs内のﾂﾘｰ第1階層のﾎﾞﾃﾞｨｰ/形状ｾｯﾄの名称のみを取得
    For Each obj In objs
        chk = False
        
        For Each b In pt.Bodies
            If obj.name = b.name Then chk = True
        Next b
        For Each hb In pt.HybridBodies
            If obj.name = hb.name Then chk = True
        Next hb
        
        If chk = True Then
            names(i) = obj.name
            i = i + 1
        End If
    Next obj
    
 '空の要素を削除
    For i = 1 To UBound(names)
        If names(i) = "" Then
            ReDim Preserve names(i - 1)
            Exit For
        End If
    Next i
    
    Get1LvNames = names()
    
End Function

Function Get1LvNames(ByVal objs As Collection) As String()

Dim names() As String

ReDim names(objs.Count)

Dim pt As Part

Set pt = CATIA.ActiveDocument.Part

Dim obj As Object

Dim b As Body

Dim hb As HybridBody

Dim chk As Boolean

Dim i As Integer: i = 1

'objs内のﾂﾘｰ第1階層のﾎﾞﾃﾞｨｰ/形状ｾｯﾄの名称のみを取得

For Each obj In objs

chk = False

For Each b In pt.Bodies

If obj.name = b.name Then chk = True

Next b

For Each hb In pt.HybridBodies

If obj.name = hb.name Then chk = True

Next hb

If chk = True Then

names(i) = obj.name

i = i + 1

End If

Next obj

'空の要素を削除

For i = 1 To UBound(names)

If names(i) = "" Then

ReDim Preserve names(i - 1)

Exit For

End If

Next i

Get1LvNames = names()

End Function

引数はボディーと形状セットの入ったコレクションで、戻り値は名称(文字列)の入った配列です。
関数内では、入力されたコレクション内からツリー第1階層のもののみを選別し、名称を取得するという処理を行なっています。

まずはSelectionオブジェクトのSearchメソッドで「ボディーと形状セットを選択→コレクションに順に格納」という処理をします。(詳しくは選択しているオブジェクトを一時保管する方法を参照)

Searchメソッドを使うことで、ツリーの上から順にボディー/形状セットを取得することができます。
これらを格納したコレクションを引数としてGet1LvNames関数に入力します。
これはSearchメソッドだけでは第1階層のボディー/形状セットを取得することができないためです。

本コードではアクティブドキュメント内の全てのボディー/形状セットをコレクションに格納しています。これをGet1LvNames関数に入力することで、第1階層のボディー/形状セットを選別し名前を取得することが可能になります。

Get1LvNames関数の処理内容は下記のとおりです。

① names()の要素数をobjsと同じ数にする
② objsコレクション内ループ
　 ③ PartオブジェクトのBodiesコレクション内のボディー名称と一致するか確認
　 ④ PartオブジェクトのHybridBodiesコレクション内の形状セット名称と一致するか確認　
　 ⑤ もし③と④のどちらかで一致した場合、names()に名称を格納
⑤ コレクション内のループが終わるまで②に戻る
⑥ names()のから要素部分を削除する
⑦ names()を返す

　
少し回りくどい処理をしていますが、ツリー第1階層のみを順番に並べるようにするにはこの関数のようにひと手間加える必要がありそうです。(VBAではボディーを扱うBodiesと形状セットを扱うHybridBodiesで別れているため、単純に取得はできなさそうです)