複数出力内の平行移動を親と同じ構造で振り分けるマクロ｜CATIAマクロの作成方法
今回は「マクロ案」よりいただいた内容です。
送って頂いた内容は以下のようなマクロです。
ワークベンチ: GSD
マクロ案:
複数のSURFACEを移動した際（平行移動）、色の情報が移動前と同じにできませんでしょうか？
移動前：形状セットの中に複数の形状セットが存在し、各々に違う色が設定してある。
移動後：同じ形状セットの構成で（できれば）色情報が移動前と同一。
データムでも問題はない。
他サイトにあった対象移動のものを参考に作成していたのですが、複雑で行き詰まりました。移動自体はマクロから外して、
移動前と移動後の2つの形状セットを比較して、
上から順に同じ色になるように作成していたのですが、なかなかうまくいきません。
ご教授お願いできませんでしょうか？
上記内容からマクロへの入力があまりうまく認識できなかったため少し意図とは違った内容になっているかもしれませんが、「平行移動と親オブジェクトの色設定」「ツリー構成の再構築」のような内容は含んでいるので何らかの参考にはなると思います。
マクロの機能
今回作成したのは選択した複数出力の平行移動に対して、親を取得しツリー構成を再構築し振り分けるマクロです。文字だとわかりづらいですが上画像を見れば何となくイメージが付くかと思います。
上画像でいうところの「複数出力.1 (平行移動)」内に入っている「平行移動.1～.10」の親オブジェクトと同じツリー構成になるよう形状セットを新規作成し、Part直下に親オブジェクトと同じ色で振り分けます。
具体的な機能は以下のとおりです。
※オブジェクトのタイプ上「形状セット」も選択できてしまうので注意
・Part直下に「＠ 選択した複数出力名」という新規セットを作成しその中に出力
・振り分けながら親オブジェクトと同じ色を付与する
VBAコード
コード全体は下記の通りです。
実行後「複数出力(平行移動)」をクリックするだけです。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 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 |
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 |
コード解説
ｱｸﾃｨﾌﾞﾄﾞｷｭﾒﾝﾄ等の定義
|
1 2 3 4 5 6 7 8 9 |
'ｱｸﾃｨﾌﾞﾋﾞｭｰ等々定義 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)取得
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
'複数出力(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」の頭文字から来ています。。
最終出力の形状ｾｯﾄを作成
|
1 2 3 4 |
'最終出力の形状ｾｯﾄを作成 Dim output_hb As HybridBody Set output_hb = pt.HybridBodies.Add output_hb.Name = "@ " & mo.Name |
次に本マクロでの出力の基準となる形状セットを作成します。
マクロで出力するものはすべてこの形状セット内に作っていきます。
最終出力の基準となる形状セットはPart直下(ツリー第一階層)に作成するようにしています。
またその形状セット名は「mo」の名称の頭に「@」を付けたものにしています。
複数出力内ループ(外枠)
|
1 2 3 4 5 6 7 8 9 |
'複数出力(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の親ｵﾌﾞｼﾞｪｸﾄ(平行移動前のｵﾌﾞｼﾞｪｸﾄ)を取得
|
1 2 3 4 5 6 |
'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の親ｵﾌﾞｼﾞｪｸﾄのﾂﾘｰ構成を取得
|
1 2 |
'hstの親ｵﾌﾞｼﾞｪｸﾄのﾂﾘｰ構成を取得 hb_names = GetHierarchy(par_hs) |
次に取得した親オブジェクトのツリー構成を取得します。
これには「GetHierarchy」という関数を作り、取得できるようにしています。
「GetHierarchy」はコード記載通り、引数として入力したオブジェクトの親となる形状セットの名称をすべて取得することのできる関数です。
取得できるのは形状セットの名称の入った文字列型の配列です。
この関数を使うことで配列の大きさ(中身の数)より、入力されたオブジェクトがツリーの第何層にあるのかも調べることができます。
処理内容としては引数「hs」の親を「Parentプロパティ」で順々に取得していき、オブジェクトタイプが「OrderedGeometricalSet」つまりは形状セットの場合にはそのオブジェクトの名前を取得するということをしています。(オブジェクトタイプはHybridBodyでも問題ないとは思います)
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
'--------------------------------------------------------------------------- ' 【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の親ｵﾌﾞｼﾞｪｸﾄ(平行移動前のｵﾌﾞｼﾞｪｸﾄ)を取得
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 |
'取得したﾂﾘｰ構成から形状ｾｯﾄを再現 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)の振り分けと色付け
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 |
'平行移動(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マクロを本気で勉強するなら
