複数出力内の平行移動を親と同じ構造で振り分けるマクロ｜CATIAマクロの作成方法
今回は「マクロ案」よりいただいた内容です。
送って頂いた内容は以下のようなマクロです。
ワークベンチ: GSD
マクロ案:
複数のSURFACEを移動した際（平行移動）、色の情報が移動前と同じにできませんでしょうか？
移動前：形状セットの中に複数の形状セットが存在し、各々に違う色が設定してある。
移動後：同じ形状セットの構成で（できれば）色情報が移動前と同一。
データムでも問題はない。
他サイトにあった対象移動のものを参考に作成していたのですが、複雑で行き詰まりました。移動自体はマクロから外して、
移動前と移動後の2つの形状セットを比較して、
上から順に同じ色になるように作成していたのですが、なかなかうまくいきません。
ご教授お願いできませんでしょうか？
上記内容からマクロへの入力があまりうまく認識できなかったため少し意図とは違った内容になっているかもしれませんが、「平行移動と親オブジェクトの色設定」「ツリー構成の再構築」のような内容は含んでいるので何らかの参考にはなると思います。
マクロの機能
今回作成したのは選択した複数出力の平行移動に対して、親を取得しツリー構成を再構築し振り分けるマクロです。文字だとわかりづらいですが上画像を見れば何となくイメージが付くかと思います。
上画像でいうところの「複数出力.1 (平行移動)」内に入っている「平行移動.1～.10」の親オブジェクトと同じツリー構成になるよう形状セットを新規作成し、Part直下に親オブジェクトと同じ色で振り分けます。
具体的な機能は以下のとおりです。
※オブジェクトのタイプ上「形状セット」も選択できてしまうので注意
・Part直下に「＠ 選択した複数出力名」という新規セットを作成しその中に出力
・振り分けながら親オブジェクトと同じ色を付与する
VBAコード
コード全体は下記の通りです。
実行後「複数出力(平行移動)」をクリックするだけです。
Option Explicit
Sub CATMain()
'ｱｸﾃｨﾌﾞﾋﾞｭｰ等々定義
Dim doc As PartDocument: Set doc = CATIA.ActiveDocument
Dim pt As Part: Set pt = doc.Part
Dim hsf As HybridShapeFactory: Set hsf = pt.HybridShapeFactory
Dim sel: Set sel = doc.Selection
Dim vps As VisPropertySet: Set vps = sel.VisProperties
Dim filter: filter = Array("HybridBody")
Dim res As String
Dim i As Long
'複数出力(Multi Output)取得
sel.Clear
res = sel.SelectElement2(filter, "複数出力を選択してください", False)
If res <> "Normal" Then
MsgBox "キャンセルしました。"
Exit Sub
End If
Dim mo As HybridBody
Set mo = sel.Item(1).Value
If InStr(mo.Name, "複数出力") = 0 Then
MsgBox "「複数出力」を選択してください。"
Exit Sub
End If
'最終出力の形状ｾｯﾄを作成
Dim output_hb As HybridBody
Set output_hb = pt.HybridBodies.Add
output_hb.Name = "@ " & mo.Name
'複数出力(Multi Output)内の平行移動(Translate)ﾙｰﾌﾟ
Dim hst
Dim hb_names() As String
For Each hst In mo.HybridShapes
If TypeName(hst) = "HybridShapeTranslate" Then
'hstの親ｵﾌﾞｼﾞｪｸﾄ(平行移動前のｵﾌﾞｼﾞｪｸﾄ)を取得
Dim ref_hst As Reference
Set ref_hst = hst.ElemToTranslate
Dim par_hs As HybridShape
Set par_hs = hsf.GSMGetObjectFromReference(ref_hst)
'hstの親ｵﾌﾞｼﾞｪｸﾄのﾂﾘｰ構成を取得
hb_names = GetHierarchy(par_hs)
'取得したﾂﾘｰ構成から形状ｾｯﾄを再現
Dim par_hb As HybridBody
Dim hb As HybridBody
Dim chk As Boolean
Set par_hb = output_hb
For i = UBound(hb_names) - 1 To LBound(hb_names) Step -1
chk = False
For Each hb In par_hb.HybridBodies
If hb.Name = hb_names(i) Then
chk = True
Set par_hb = hb
Exit For
End If
Next hb
If chk = False Then
Dim tmp_hb As HybridBody
Set tmp_hb = par_hb.HybridBodies.Add
tmp_hb.Name = hb_names(i)
Set par_hb = tmp_hb
End If
Next i
'平行移動(Translate)をｺﾋﾟｰ
sel.Clear
sel.Add hst
sel.Copy
'平行移動(Translate)の親ｵﾌﾞｼﾞｪｸﾄの色取得
sel.Clear
sel.Add par_hs
Dim R As Long, G As Long, B As Long
vps.GetRealColor R, G, B
'平行移動(Translate)を貼り付け & 取得していた色設定
sel.Clear
sel.Add par_hb
sel.Paste
vps.SetRealColor R, G, B, 0
End If
Next hst
sel.Clear
End Sub
'---------------------------------------------------------------------------
' 【GetHierarchy関数】
' 引数：hs 戻り値：String()
' 機能：hsの親を順々に調べ、形状ｾｯﾄ名をすべて配列に格納して返す
' ex ﾂﾘｰ構成が「 Part > 形状ｾｯﾄ.1 > 形状ｾｯﾄ.2 > hs 」の場合
' 返り値には(形状ｾｯﾄ.2,形状ｾｯﾄ.1)の順で形状ｾｯﾄ名が格納される
'---------------------------------------------------------------------------
Function GetHierarchy(ByVal hs As HybridShape) As String()
Dim cnt As Long
Dim i As Long
Dim tmp As AnyObject
Dim hb_names() As String
ReDim hb_names(0)
Set tmp = hs.Thickness
Do Until TypeName(tmp) = "PartDocument"
Set tmp = tmp.Parent
If TypeName(tmp) = "OrderedGeometricalSet" Then
If cnt = 0 Then
hb_names(cnt) = tmp.Name
Else
ReDim Preserve hb_names(cnt + 1)
hb_names(cnt) = tmp.Name
End If
cnt = cnt + 1
End If
Loop
GetHierarchy = hb_names
End Function
コード解説
ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ等の定義
'ｱｸﾃｨﾌﾞﾋﾞｭｰ等々定義
Dim doc As PartDocument: Set doc = CATIA.ActiveDocument
Dim pt As Part: Set pt = doc.Part
Dim hsf As HybridShapeFactory: Set hsf = pt.HybridShapeFactory
Dim sel: Set sel = doc.Selection
Dim vps As VisPropertySet: Set vps = sel.VisProperties
Dim filter: filter = Array("HybridBody")
Dim res As String
Dim i As Long
まずはじめにアクティブドキュメントをはじめ以降で使うオブジェクト/変数を定義をします。
Partオブジェクト ：オブジェクト定義/Reference作成等用
HybridShapeFactoryオブジェクト ：平行移動の親オブジェクト(移動元)取得用
Selectionオブジェクト ：ユーザー選択でのオブジェクト取得用
VisPropertySetオブジェクト ：平行移動オブジェクトの色変更用
filter / res ：SelectElement2用
i ：カウント変数
複数選択(Multi Output)取得
'複数出力(Multi Output)取得
sel.Clear
res = sel.SelectElement2(filter, "複数出力を選択してください", False)
If res <> "Normal" Then
MsgBox "キャンセルしました。"
Exit Sub
End If
Dim mo As HybridBody
Set mo = sel.Item(1).Value
If InStr(mo.Name, "複数出力") = 0 Then
MsgBox "「複数出力」を選択してください。"
Exit Sub
End If
次にSelectElement2メソッドを使ってユーザー選択より「複数出力」を取得します。
VBAでのオブジェクトタイプは「HybridBody」となっており、形状セットと同じ扱いです。
そのためここでは選択したオブジェクトの名前に「"複数出力"」という文字列が入っているかいないかで、複数出力の判定をしています。(デフォルトでは"複数出力.x"という名前のため)
ちなみに上記コードの「mo」は英語版の「Multi Output」の頭文字から来ています。。
最終出力の形状ｾｯﾄを作成
'最終出力の形状ｾｯﾄを作成
Dim output_hb As HybridBody
Set output_hb = pt.HybridBodies.Add
output_hb.Name = "@ " & mo.Name
次に本マクロでの出力の基準となる形状セットを作成します。
マクロで出力するものはすべてこの形状セット内に作っていきます。
最終出力の基準となる形状セットはPart直下(ツリー第一階層)に作成するようにしています。
またその形状セット名は「mo」の名称の頭に「@」を付けたものにしています。
複数出力内ループ(外枠)
'複数出力(Multi Output)内の平行移動(Translate)ﾙｰﾌﾟ
Dim hst
Dim hb_names() As String
For Each hst In mo.HybridShapes
If TypeName(hst) = "HybridShapeTranslate" Then
：
：
End If
Next hst
次に複数出力「mo」内ループをして全平行移動に対して処理を行っていきます。
「mo」は形状セットと同じく「HybridBody」のため、「For Each hst In mo.HybridShapes」というように書くことで、「hst」の中身順に入れ替えながらループさせることができます。
つまりこのループ内で「hst」に対して処理を行えば、複数出力内のすべての平行移動にそれらの処理を適応できるという訳です。
また、このとき条件分岐でオブジェクトのタイプが平行移動(HybridShapeTranslate)以外のものは無視するようにしています。
以降はこの「mo」内ループの中身についての内容です。
hstの親ｵﾌﾞｼﾞｪｸﾄ(平行移動前のｵﾌﾞｼﾞｪｸﾄ)を取得
'hstの親ｵﾌﾞｼﾞｪｸﾄ(平行移動前のｵﾌﾞｼﾞｪｸﾄ)を取得
Dim ref_hst As Reference
Set ref_hst = hst.ElemToTranslate
Dim par_hs As HybridShape
Set par_hs = hsf.GSMGetObjectFromReference(ref_hst)
次にループ内の処理です。
まずはhstの親オブジェクトを取得します。
ここでいう親は平行移動の移動前となるオブジェクトのことで、VBAでいう親ではありません。
処理内容としては親オブジェクトのReferenceを取得し、それをオブジェクトに変換するということをやっています。
親オブジェクトのReferenceは「HybridShapeTranslateオブジェクト」の「ElemToTranslateプロパティ」より取得することができます。このReferenceをオブジェクトに変換するには「HybridShapeFactoryオブジェクト」の「GSMGetObjectFromReferenceメソッド」により行えます。
hstの親ｵﾌﾞｼﾞｪｸﾄのﾂﾘｰ構成を取得
'hstの親ｵﾌﾞｼﾞｪｸﾄのﾂﾘｰ構成を取得
hb_names = GetHierarchy(par_hs)
次に取得した親オブジェクトのツリー構成を取得します。
これには「GetHierarchy」という関数を作り、取得できるようにしています。
「GetHierarchy」はコード記載通り、引数として入力したオブジェクトの親となる形状セットの名称をすべて取得することのできる関数です。
取得できるのは形状セットの名称の入った文字列型の配列です。
この関数を使うことで配列の大きさ(中身の数)より、入力されたオブジェクトがツリーの第何層にあるのかも調べることができます。
処理内容としては引数「hs」の親を「Parentプロパティ」で順々に取得していき、オブジェクトタイプが「OrderedGeometricalSet」つまりは形状セットの場合にはそのオブジェクトの名前を取得するということをしています。(オブジェクトタイプはHybridBodyでも問題ないとは思います)
'---------------------------------------------------------------------------
' 【GetHierarchy関数】
' 引数：hs 戻り値：String()
' 機能：hsの親を順々に調べ、形状ｾｯﾄ名をすべて配列に格納して返す
' ex ﾂﾘｰ構成が「 Part > 形状ｾｯﾄ.1 > 形状ｾｯﾄ.2 > hs 」の場合
' 返り値には(形状ｾｯﾄ.2,形状ｾｯﾄ.1)の順で形状ｾｯﾄ名が格納される
'---------------------------------------------------------------------------
Function GetHierarchy(ByVal hs As HybridShape) As String()
Dim cnt As Long
Dim i As Long
Dim tmp As AnyObject
Dim hb_names() As String
ReDim hb_names(0)
Set tmp = hs.Thickness
Do Until TypeName(tmp) = "PartDocument"
Set tmp = tmp.Parent
If TypeName(tmp) = "OrderedGeometricalSet" Then
If cnt = 0 Then
hb_names(cnt) = tmp.Name
Else
ReDim Preserve hb_names(cnt + 1)
hb_names(cnt) = tmp.Name
End If
cnt = cnt + 1
End If
Loop
GetHierarchy = hb_names
End Function
この関数により親オブジェクトの形状セット構成が取得できます。
あとはこの情報をもとにツリーを「output_hb」内に再構築してくだけです。
hstの親ｵﾌﾞｼﾞｪｸﾄ(平行移動前のｵﾌﾞｼﾞｪｸﾄ)を取得
'取得したﾂﾘｰ構成から形状ｾｯﾄを再現
Dim par_hb As HybridBody
Dim hb As HybridBody
Dim chk As Boolean
Set par_hb = output_hb
For i = UBound(hb_names) - 1 To LBound(hb_names) Step -1
chk = False
For Each hb In par_hb.HybridBodies
If hb.Name = hb_names(i) Then
chk = True
Set par_hb = hb
Exit For
End If
Next hb
If chk = False Then
Dim tmp_hb As HybridBody
Set tmp_hb = par_hb.HybridBodies.Add
tmp_hb.Name = hb_names(i)
Set par_hb = tmp_hb
End If
Next i
つぎにツリーの再構築です。
「GetHierarchy」により取得した情報は「hb_names」に入っています。
たとえば「 Part > 形状ｾｯﾄ.1 > 形状ｾｯﾄ.2 > hs 」というような構成の場合、形状セット.1と.2の２つの名称が格納されています。ただ「GetHierarchy」は子から親に向かって形状セット名を取得しているので、配列の順番は逆転しています。
つまり今の例だと hb_names(0)="形状ｾｯﾄ.2″ , hb_names(1)="形状ｾｯﾄ.1″ となります。
そのためここでは「Step -1」を使って逆向きの「hb_names」内ループを行っています。
コードは少し複雑ですが処理内容は単純で、セット内にhb_names(i)と同じセット名の形状セットが無ければ新規で作成ということを親の形状セットを変えながら繰り返しているだけです。
平行移動(Translate)の振り分けと色付け
'平行移動(Translate)をｺﾋﾟｰ
sel.Clear
sel.Add hst
sel.Copy
'平行移動(Translate)の親ｵﾌﾞｼﾞｪｸﾄの色取得
sel.Clear
sel.Add par_hs
Dim R As Long, G As Long, B As Long
vps.GetRealColor R, G, B
'平行移動(Translate)を貼り付け & 取得していた色設定
sel.Clear
sel.Add par_hb
sel.Paste
vps.SetRealColor R, G, B, 0
ループの最後に再構築した形状セット内に平行移動をコピペします。
処理内容は単純にSelectionオブジェクト の「Copy/Pasteメソッド」を使っているだけです。
(振り分けというよりは複製しているだけ)
また、ここであわせて親オブジェクトの色を取得し、振り分けた平行移動に色を付けます。
色の取得と設定はVisPropertySetオブジェクトページを参照下さい。
まとめ
今回は選択した複数出力の平行移動に対して、親を取得しツリー構成を再構築し振り分けるマクロについての内容でした。
ご連絡頂いた内容とは少し認識が違ったものになっているような気はしますが、必要そうな内容はすべて盛り込んでいるのでうまいこと書き換えてみて下さい。(どうしてもわからなければまたご連絡ください)
また、本サンプルコードには「親オブジェクトの取得」や「ツリーの再構築」のような他のマクロでも使えそう内容もちらほらあったので、それらを別のマクロで使ってみるとよりCATIAマクロの理解が深まると思います。
CATIAマクロを本気で勉強するなら
