ｻｰﾌｪｽの色をﾎﾞﾃﾞｨに反映する2

こちらの続きですが、ﾀｲﾄﾙ名がふさわしくないです。

ｻｰﾌｪｽの色をﾎﾞﾃﾞｨに反映する - C#ATIA

takashiさんからｺﾒﾝﾄを頂き、早速ご要望を反映してみました。

'vba sample_ApplyColor_ver0.0.2  using-'KCL0.0.10'
'指定した形状ｾｯﾄ(ﾎﾞﾃﾞｨ)の面の色をﾎﾞﾃﾞｨ(形状ｾｯﾄ)に(大体)反映する
Option Explicit

'*** 設定値 ***
Const CogTolerance = 0.01  '同一判断重心距離
Const AreaTolerance = 0.01 '同一判断面積
'**************

Const CogTolSqr = CogTolerance * CogTolerance

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    Dim Doc As Document: Set Doc = CATIA.ActiveDocument
    If Not (KCL.IsType_Of_T(Doc, "PartDocument") Or _
            KCL.IsType_Of_T(Doc, "ProductDocument")) Then
        MsgBox "Part か Product でしか利用できません!"
        Exit Sub
    End If
    
    '形状ｾｯﾄ選択
    Dim Msg$: Msg = "色の参照元となる形状ｾｯﾄ(ﾎﾞﾃﾞｨ)を選択して下さい : ESCｷｰ 終了"
    Dim HB As AnyObject
    Set HB = KCL.SelectItem(Msg, Array("HybridBody", "Body"))
    If KCL.IsNothing(HB) Then Exit Sub
    Dim HBRefs As Variant: HBRefs = GetTopoFacesRef(HB)
    If IsEmpty(HBRefs) Then Exit Sub
    
    'ﾎﾞﾃﾞｨ選択
    Msg = "色を反映するﾎﾞﾃﾞｨ(形状ｾｯﾄ)を選択して下さい : ESCｷｰ 終了"
    Dim Bdy As AnyObject
    Set Bdy = KCL.SelectItem(Msg, Array("HybridBody", "Body"))
    If KCL.IsNothing(Bdy) Then Exit Sub
    Dim BdyRefs As Variant: BdyRefs = GetTopoFacesRef(Bdy)
    If IsEmpty(BdyRefs) Then Exit Sub
    
    '確認
    Msg = HB.Name + "(" + CStr(UBound(HBRefs) + 1) + "枚)の色を" + vbNewLine + _
          Bdy.Name + "(" + CStr(UBound(BdyRefs) + 1) + "枚)に" + vbNewLine + _
          "反映しますか?"
    If MsgBox(Msg, vbYesNo) = vbNo Then Exit Sub
    
    '形状ｾｯﾄﾄﾎﾟﾛｼﾞ情報取得
    Dim HBGeos As Variant
    HBGeos = GetGeoInfo(HB, HBRefs)
    
    'ﾎﾞﾃﾞｨﾄﾎﾟﾛｼﾞ情報取得
    Dim BdyGeos As Variant
    BdyGeos = GetGeoInfo(Bdy, BdyRefs)
    
    '形状ｾｯﾄｶﾗｰ情報取得
    Dim HBColor As Variant
    HBColor = GetColor(HB, HBRefs)
    
    '重心・面積から反映色を決める
    Dim BdyColor As Variant
    BdyColor = DecideApplyColor(HBGeos, BdyGeos, HBColor)
    
    '色の反映
    Call SetColor(Bdy, BdyRefs, BdyColor)
    
    '終了
    Call OjUpdate(Bdy)
    MsgBox "反映終了"
End Sub

'更新
Private Sub OjUpdate(ByRef AnyOj As AnyObject)
    Dim Pt As Part: Set Pt = KCL.GetParent_Of_T(AnyOj, "PartDocument").Part
    Pt.UpdateObject AnyOj
End Sub

'重心・面積から反映色を決める
Private Function DecideApplyColor(ByRef HBGeos As Variant, _
                                  ByRef BdyGeos As Variant, _
                                  ByVal HBColors As Variant) As Variant
    Dim BdyColors() As Variant: ReDim BdyColors(UBound(BdyGeos))
    Dim i&, j&
    For i = 0 To UBound(BdyGeos)
        For j = 0 To UBound(HBGeos)
            If IsCogEqual(BdyGeos(i), HBGeos(j)) And _
               IsAreaEqual(BdyGeos(i), HBGeos(j)) Then
                BdyColors(i) = HBColors(j)
                Exit For
            End If
        Next
    Next
    DecideApplyColor = BdyColors
End Function

'COG一致
Private Function IsCogEqual(ByVal P1 As Variant, ByVal P2 As Variant) As Boolean
    IsCogEqual = False
    If Abs((P2(0) - P1(0)) * (P2(0) - P1(0)) + _
           (P2(1) - P1(1)) * (P2(1) - P1(1)) + _
           (P2(2) - P1(2)) * (P2(2) - P1(2))) < CogTolSqr Then
        IsCogEqual = True
    End If
End Function

'Area一致
Private Function IsAreaEqual(ByVal P1 As Variant, ByVal P2 As Variant) As Boolean
    IsAreaEqual = False
    If Abs(P2(3) - P1(3)) < AreaTolerance Then
        IsAreaEqual = True
    End If
End Function

'色情報反映
Private Sub SetColor(ByVal ParentOj As AnyObject, ByRef Refs As Variant, ByVal Colors As Variant)
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(ParentOj, "PartDocument")
    Dim Sel As Selection: Set Sel = Doc.Selection
    Dim VPS As VisPropertySet: Set VPS = Sel.VisProperties
    Dim i&
    
    CATIA.HSOSynchronized = False
    For i = 0 To UBound(Colors)
        If IsEmpty(Colors(i)) Then GoTo Continue
        With Sel
            .Clear
            .Add Refs(i)
        End With
        VPS.SetRealColor Colors(i)(0), Colors(i)(1), Colors(i)(2), 1
Continue:
    Next
    CATIA.HSOSynchronized = True
End Sub

'色情報の取得
Private Function GetColor(ByVal ParentOj As AnyObject, ByRef Refs As Variant) As Variant
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(ParentOj, "PartDocument")
    Dim Sel As Selection: Set Sel = Doc.Selection
    Dim VPS As VisPropertySet: Set VPS = Sel.VisProperties
    Dim i&, r&, g&, b&
    Dim Colors() As Variant: ReDim Colors(UBound(Refs))
    
    CATIA.HSOSynchronized = False
    For i = 0 To UBound(Refs)
        With Sel
            .Clear
            .Add Refs(i)
        End With
        VPS.GetRealColor r, g, b
        Colors(i) = Array(r, g, b)
    Next
    CATIA.HSOSynchronized = True
    
    GetColor = Colors
End Function

'CogとAreaの取得
Private Function GetGeoInfo(ByVal ParentOj As AnyObject, ByRef Refs As Variant) As Variant
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(ParentOj, "PartDocument")
    Dim SPA As SPAWorkbench: Set SPA = Doc.GetWorkbench("SPAWorkbench")
    Dim Infos() As Variant: ReDim Infos(UBound(Refs))
    Dim Cog(2) As Variant, i&, Mes As Variant 'Measurable
    
    For i = 0 To UBound(Infos)
        Set Mes = SPA.GetMeasurable(Refs(i))
        Mes.GetCOG Cog
        Infos(i) = KCL.JoinAry(Cog, Array(Mes.Area))
    Next
    
    GetGeoInfo = Infos
End Function

'topologyのFaceのReference取得
Private Function GetTopoFacesRef(ByVal AnyOj As AnyObject) As Variant
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(AnyOj, "PartDocument")
    Dim Sel As Selection: Set Sel = Doc.Selection
    
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add AnyOj
        .Search "Topology.CGMFace,sel"
    End With
    If Sel.Count2 < 1 Then Exit Function
    
    Dim Pt As Part: Set Pt = Doc.Part
    Dim Refs() As Reference: ReDim Refs(Sel.Count2 - 1)
    Dim i&, Face As AnyObject
    For i = 0 To Sel.Count2 - 1
        Set Refs(i) = Sel.Item(i + 1).Reference
    Next
    CATIA.HSOSynchronized = True
    
    GetTopoFacesRef = Refs
End Function

CATMainのﾕｰｻﾞｰに選択してもらう部分をちょっと修正しただけです。
(その為、変数名がふさわしくない状態になっておりますが･･･)

ｻｰﾌｪｽ(形状ｾｯﾄ)　⇔　ｿﾘｯﾄﾞ
ｻｰﾌｪｽ(形状ｾｯﾄ)　⇔　ｻｰﾌｪｽ(形状ｾｯﾄ)
ｿﾘｯﾄﾞ　⇔　ｿﾘｯﾄﾞ
間のｶﾗｰ反映が出来るようになっております。
(時系列ｾｯﾄは未対応)

処理速度については、遅い原因がわかっています。
現状の処理では、お互いの面の枚数分総当りで一致するかどうかを
ﾁｪｯｸしているのですが、これが非常に効率悪いです。
重心位置を元に、過去に取り組んだﾓｰﾄﾝ順序の8分木空間分割を
利用する事で、組み合わせ数を大幅に減らせ処理速度が速くなるだろう
とは思っておりますが、それなりにﾊﾟﾜｰが必要でして･･･。

Autodesk Certified User

PowerMillは、常に蚊帳の外…

Certiport | Home - Certify to Succeed

PowerMill2018ｲﾝｽﾄｰﾙして見ました

複数ﾊﾞｰｼﾞｮﾝのｲﾝｽﾄｰﾙが出来たので、PowerMill2018をｲﾝｽﾄｰﾙ
して見ました。
・・・ﾊﾞｸﾞっぽいものが随所に見られ、SP2ぐらいまでは使わない
と決めました。

特に痛いのが、こちらのｺﾝﾃｷｽﾄﾒﾆｭｰからﾏｸﾛの呼び出しが出来ない事。
2018 User menu bug - Autodesk Community

作業のやり難さを改善できたと思っていたのに、
これらが利用できません。

工具ｺﾝﾃｷｽﾄﾒﾆｭｰから工具変更 - C#ATIA

ｺﾝﾃｷｽﾄﾒﾆｭｰからﾌｫﾙﾀﾞを展開する - C#ATIA

他にも幾つか、この方法で呼び出すﾏｸﾛがあるのですが･･･。

ﾌｫｰﾗﾑにはﾊﾞｸﾞって投稿されているのですが、ﾒｰｶｰさん的には
もっと先を見据えて、保留したのかな？
Fusion360やReMakeのｺﾝﾃｷｽﾄﾒﾆｭｰのような、円形のものに
将来的にはなるんじゃないのかな？

環境変数 CAT_VBAIsOutProc

これ知りませんでした。

COE : Forums : CAT_VBAIsOutProc

確かにVBA6(32bit)からVBA7(64bit)に移行した際、
動かないﾏｸﾛが幾つかありました。(KCLも)

起動するCATIAの環境変数にこれを追加することで
VBA7でも32bitとして実行できるようです。

何れは64bitとしてｺｰﾄﾞを修正すべきですが、
"今、使いたい！！"
って時には良いかも。

PowerMill2018

ﾌｫｰﾗﾑではﾁﾗﾁﾗ名前が出てましたが、"What’s new" なｻｲﾄが出来てました。

PowerMill 2018 | New Features | Autodesk

ﾘﾝｸ先がｽｶｽｶなんですが、動画は見れました。

"Ribbon interface" になるのは別に構わないのですが、こちらの動画の16秒辺りに出てくる
ﾂｰﾙﾊﾟｽｺﾈｸﾀｰﾀﾞｲｱﾛｸﾞの異常な大きさを何とかして欲しい。
(一度閉じないと、修正後の状態が見れません･･･)

"3D offset with center-line" 確かに他のCAMでも中心部に指定ﾋﾟｯﾁ以上2倍以下の
部分が残る場合が多いです。　外→内でこれが出来るのであれば良いかも。

"Stock simulation" PowerMillには幾つかｼﾐｭﾚｰｼｮﾝのﾀｲﾌﾟがあるのですが、
そのうちのViewMillと言うｼﾐｭﾚｰｼｮﾝのお話。
実は2017まで、ｼﾐｭﾚｰｼｮﾝを始めた向きから回転させる事が出来ないと言う
今時ありえない仕様だったのですが、ようやく回転させられるように
なるんですね。　･･･使わない気がしますが。

動画を見る限り後は関係ないかな・・・。
旋盤も、5軸も、複合機も、ｲﾝﾃﾞｯｸｽﾃｰﾌﾞﾙも、ﾕﾆﾊﾞｰｻﾙﾍｯﾄﾞも無いので。

ｺﾝﾃｷｽﾄﾒﾆｭｰからﾌｫﾙﾀﾞを展開する

PowerMillには僕の知る限り、古いﾊﾞｰｼﾞｮﾝからﾌｫﾙﾀﾞの機能があります。
このﾌｫﾙﾀﾞなのですが、WinなExplorer(ﾃﾞｨﾚｸﾄﾘ)とはちょっと挙動が
異なり、何となく要望があって後から付け加えた機能にも感じます。

もちろんﾌｫﾙﾀﾞ機能が無ければ、Treeが長すぎて扱いにくくなる為
活用しています。(社内では僕だけですが･･･)

このﾌｫﾙﾀﾞを展開したり縮小したりが・・・・まとめて出来ない！
そう、CATIAのこんな感じの機能が欲しいんです。

(CATIAもここにあるので、案外使わないのですが)

こちらのすごいﾏｸﾛを参考に作ってみました。
(正確には、ほぼﾊﾟｸﾘ)
Solved: Create macro to pick folder and activate it - Autodesk Community

まず、実際にﾌｫﾙﾀﾞの展開縮小を行うﾏｸﾛです。
(TreeExpansion.mac　としておきます)

//PMill_Macro
//TreeExpansion.mac

function main(string FolderType, int Level) {
	string list ValidFolderNames={'ncprogram','toolpath','tool','boundary','pattern','featureset','featuregroup','workplane','model','stockmodel'}
	IF not member($ValidFolderNames,lcase($FolderType)) {
		MESSAGE ERROR '不適切なﾌｫﾙﾀﾞ名です！'
		RETURN
	}	
	string list Folders = get_folders($FolderType)
	IF (size($Folders) == 0) {
		RETURN
	}

	$Folders=reverse($Folders)
	string cmd = 'EXPLORER SELECT $FolderType ROOT'
	DoCommand $cmd

	//全部閉じる
	if $Level == 0 {
		DEBUG EXPLORER KEY LEFT
		RETURN
	}
   
	DEBUG EXPLORER KEY RIGHT_RECURSIVE
	
	//全部開く
	if $Level < 0 {
		RETURN
	}
	
   foreach ff in folders {
      EXPLORER SELECT FOLDER $ff NEW
      DEBUG EXPLORER KEY LEFT
   } 
   
	//1ﾚﾍﾞﾙ
 	if $Level == 1 {
		RETURN
	}  
   
	//nﾚﾍﾞﾙ
	string list Lv_n_Fols = {}
	foreach ff in folders {
		string list f=tokens($ff,'\')
		IF (size($f) == ($Level + 1)) {
			int dmy = add_last($Lv_n_Fols, dirname($ff))
		}
	} 
	
 	if size($Lv_n_Fols) == 0 {
		//指定ﾚﾍﾞﾙまでﾌｫﾙﾀﾞなし-全展開
		string cmd = 'EXPLORER SELECT $FolderType ROOT'
		DoCommand $cmd
		DEBUG EXPLORER KEY RIGHT_RECURSIVE
		RETURN
	} 
	
	foreach ff in Lv_n_Fols {
		EXPLORER SELECT FOLDER $ff NEW
		DEBUG EXPLORER KEY RIGHT
	} 	
}

念のため、このﾏｸﾛ単体では動きません。

CATIAの様にﾒﾆｭｰからの呼び出しが面倒な為、ﾏｸﾛの呼び出しはｺﾝﾃｷｽﾄﾒﾆｭｰから
行いたいです。　以前行ったこちらの様に。
工具ｺﾝﾃｷｽﾄﾒﾆｭｰから工具変更 - C#ATIA

その為、toolpath.XML に追記します。
(この辺の方法は、Helpのｶｽﾀﾑﾒﾆｭｰ辺りに記載されています)

<?xml version="1.0"  encoding="utf-8" ?>

<menupage>
	<menupage label="ﾂﾘｰ展開">
		<button label="全て縮小" command='MACRO all\TreeExpansion.mac "toolpath" 0' />	
		<spacer/>
		<button label="1次展開" command='MACRO all\TreeExpansion.mac "toolpath" 1' />
		<button label="2次展開" command='MACRO all\TreeExpansion.mac "toolpath" 2' />
		<button label="全て展開" command='MACRO all\TreeExpansion.mac "toolpath" -1' />
	</menupage>
	
	・・・

</menupage>

実際に設定した上での操作はこんな感じです。

個人的には楽になりそうです。
が、もうちょっと操作性を良くしたいんですけど、設定ﾌｧｲﾙを編集する
必要性が有りそうなので、迷い中。

GSMGetObjectFromReference

COEにこんな記載が
http://www.coe.org/p/fo/st/thread=29679

ﾘﾌｧﾚﾝｽからｵﾌﾞｼﾞｪｸﾄを取得する関数。
使わないので忘れていたのですが、利用価値が無いわけじゃ
無いと思ってます。

ﾄﾞｷｭﾒﾝﾄに記載されていないので、忘れるわけです･･･。
と言う理由での覚書。