ｻｰﾌｪｽの色をﾎﾞﾃﾞｨに反映する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分木空間分割を
利用する事で、組み合わせ数を大幅に減らせ処理速度が速くなるだろう
とは思っておりますが、それなりにﾊﾟﾜｰが必要でして･･･。