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

昔と異なり最近は、客先から3DCADﾃﾞｰﾀを受け取って作業を行うことが
殆どなのですが、当然全ての客先がCATIAを使っているわけでは無い為、
中間ﾌｫｰﾏｯﾄ(Parasolid,Acis,Step,Iges)で受け取る事が殆どです。
(ﾒｰｶｰさんがCATIAでも、間に数社はいるとCATIAでもらえない･･･。)

お金が無い為、うちの場合はCATIAはIgesでしか受け取れないのが
現状なのですが、ﾈｲﾃｨﾌﾞﾃﾞｰﾀがｿﾘｯﾄﾞであってもｲﾝﾎﾟｰﾄすると
ｻｰﾌｪｽに分解されている事が、度々有ります。
原因としては、こちらに記載されているような内容かな?　と思っています。
5．位相と幾何の調和｜研究室｜株式会社エムシースクウェアド

ｿﾘｯﾄﾞ化する際、形状自体を修正するのは大きな手間では無いのですが
一番困るのが "色" です。　支給されるﾃﾞｰﾀの色は、加工代を設置する
(公差のうるさい部分)だったり、変更箇所、確認事項･･･等　
単に "色が付いている" と言う訳ではない場合が多いような気がしています。
これを1枚1枚、手動で反映するのは結構な手間のような気がしますので、
ﾏｸﾛを作成してみました。

'vba sample_ApplyColor_ver0.01  using-'KCL'
'指定した形状ｾｯﾄの面の色をﾎﾞﾃﾞｨに(大体)反映する
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 (IsType_Of_T(Doc, "PartDocument") Or _
            IsType_Of_T(Doc, "ProductDocument")) Then
        MsgBox "Part か Product でしか利用できません!"
        Exit Sub
    End If
    
    '形状ｾｯﾄ選択
    Dim Msg$: Msg = "色の参照元となる形状ｾｯﾄを選択して下さい : ESCｷｰ 終了"
    Dim HB As HybridBody
    Set HB = KCL.SelectItem(Msg, Array("HybridBody"))
    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 Body
    Set Bdy = KCL.SelectItem(Msg, Array("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

ﾏｸﾛ実行後、色の参照元となるｻｰﾌｪｽの入った形状ｾｯﾄを指定。
続いて、色を反映するﾎﾞﾃﾞｨを指定。
形状ｾｯﾄ内の面の数と、ﾎﾞﾃﾞｨの面の数を表示したﾀﾞｲｱﾛｸﾞが出るので、
「はい」で実行されます。
(お互いの面の数が一致しなくても、実行できます。　反映される面は少ないですが)
からくりとしては、お互いの面の重心と表面積がﾄﾚﾗﾝｽ以内に入っている
場合を "元の面" と判断し、色を反映させています。

実際に実行させてみましょう。

画像右側がIgesﾃﾞｰﾀを変換したもので、ｻｰﾌｪｽ郡が形状ｾｯﾄ1に入っています。
左側が隙間があったので修正しつつﾎﾞﾃﾞｨ化したものです。
CATPartでも利用可能ですが、画像の様に同一のCATProductに入っていても
可能です。　但し、それぞれのPart内の原点と面の位置関係で "元の面" と
判断させています。

このようなﾀﾞｲｱﾛｸﾞが出ます。それぞれの面の枚数は、検索の "ﾄﾎﾟﾛｼﾞ" - "ﾌｪｰｽ"
でHITした枚数となります。

最終的には、このような感じになります。

"元の面" を判断するﾄﾚﾗﾝｽは、最初の方に記載している定数
"CogTolerance" と "AreaTolerance" になっているのですが、
どの程度が適切な値なのかよく判っておりません。　上手くいかない場合は
少し甘くすると良いかも知れません。

今回は、形状ｾｯﾄ - ﾎﾞﾃﾞｨ の処理にしましたが、ひょっとしたら
形状変更前と形状変更後で処理させて、変更部分のみを色を変える
って事も出来るかも知れないですね。

もっと早くこれを作っておけば良かった。　先日、結構苦労しましたから･･･。