形状ｾｯﾄ要素の対称化ﾏｸﾛ2

こちらの続きです。
形状ｾｯﾄ要素の対称化ﾏｸﾛ - C#ATIA

元の対称化するマクロですが、色の反映を追加しました。

'vba 指定した形状ｾｯﾄを対称化しｺﾋﾟﾍﾟ2
Option Explicit

Dim PartDoc As PartDocument
Dim Part As Part
Dim sel 'As Selection
Dim HSFact As HybridShapeFactory
Dim BasePlane As Reference
Dim DeleteItems As New Collection

Sub CATMain()
    '初期設定
    Set PartDoc = CATIA.ActiveDocument
    Set Part = PartDoc.Part
    Set sel = PartDoc.selection
    
    '元の形状ｾｯﾄ選択
    Dim BaseHBody As HybridBody
    Set BaseHBody = SelectHybridBody
    
    '対象平面選択
    Set BasePlane = SelectPlanarFace
    
    '形状ｾｯﾄｺﾋﾟﾍﾟ
    Dim MirrerHBody As HybridBody
    Set MirrerHBody = CopyPasteHybridBody(BaseHBody)
    MirrerHBody.Name = BaseHBody.Name + "_Symmetry"
    
    '対称化
    Set HSFact = Part.HybridShapeFactory
    Call HBodyLoop(MirrerHBody)
    
    '終了
    Call DeleteItem
    Part.Update
    MsgBox ("終了")
End Sub

'ｺﾋﾟﾍﾟした要素を削除
Private Sub DeleteItem()
    Dim Ref As Reference
    For Each Ref In DeleteItems
        Call HSFact.DeleteObjectForDatum(Ref)
    Next
End Sub

'形状ｾｯﾄﾙｰﾌﾟ-再帰
Private Sub HBodyLoop(HBody As HybridBody)
    Call SymmetryItem(HBody.HybridShapes)
    If HBody.HybridBodies.Count = 0 Then Exit Sub '下階層無し
    
    Dim HB As HybridBody
    For Each HB In HBody.HybridBodies
        Call HBodyLoop(HB)
    Next
End Sub

'対称
Private Sub SymmetryItem(HShapes As HybridShapes)
    Dim HShape As HybridShape
    Dim Ref As Reference
    Dim rgb As Variant
    Dim sym As HybridShape
    
    For Each HShape In HShapes
        Set Ref = Part.CreateReferenceFromObject(HShape)
        rgb = GetColor(HShape)
        If HSFact.GetGeometricalFeatureType(Ref) <> 0 Then
            Call DeleteItems.Add(Ref) '削除登録
            Set sym = CreateDatum(CreateSymmetry(Ref, BasePlane))
            Call setColor(sym, rgb)
            Call HShapes.Parent.AppendHybridShape(sym)
        End If
    Next
End Sub

'色取得
Private Function GetColor( _
    ByVal shape As HybridShape) As Variant
    
    sel.Clear
    sel.Add shape
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    Dim rgb(2) As Long
    vis.GetRealColor rgb(0), rgb(1), rgb(2)
    
    sel.Clear
    GetColor = rgb
End Function

'色設定
Private Sub setColor( _
    ByVal shape As HybridShape, _
    ByVal rgb As Variant)
        
    sel.Clear
    sel.Add shape
    
    Dim vis As VisPropertySet
    Set vis = sel.VisProperties
    
    Call vis.SetRealColor(rgb(0), rgb(1), rgb(2), 1)
    sel.Clear
End Sub

'Symmetry
Private Function CreateSymmetry(ItemRef As Reference, PlaneRef As Reference) As Reference
    Dim Symmetry As HybridShapeSymmetry
    Set Symmetry = HSFact.AddNewSymmetry(ItemRef, PlaneRef)
    Symmetry.VolumeResult = False
    Call Part.UpdateObject(Symmetry)
    Set CreateSymmetry = Part.CreateReferenceFromObject(Symmetry)
    Call DeleteItems.Add(CreateSymmetry) '削除登録
End Function

'Datum
Private Function CreateDatum(Ref As Reference) As AnyObject
    Dim Datum As AnyObject
    Select Case HSFact.GetGeometricalFeatureType(Ref)
        Case 1 'Point
            Set Datum = HSFact.AddNewPointDatum(Ref)
        Case 2 'Curve
            Set Datum = HSFact.AddNewCurveDatum(Ref)
        Case 3 'Line
            Set Datum = HSFact.AddNewLineDatum(Ref)
        Case 4 'Circle
            Set Datum = HSFact.AddNewCircleDatum(Ref)
        Case 5 'Surface
            Set Datum = HSFact.AddNewSurfaceDatum(Ref)
        Case 6 'Plane
            Set Datum = HSFact.AddNewPlaneDatum(Ref)
        Case 7 'Volume
            Set Datum = HSFact.AddNewVolumeDatum(Ref)
    End Select
    Call Part.UpdateObject(Datum)
    Set CreateDatum = Datum
End Function

'形状ｾｯﾄのｺﾋﾟﾍﾟ
Private Function CopyPasteHybridBody(HBody As HybridBody) As HybridBody
    With sel
        .Clear
        .Add HBody
        .Copy
        .Clear
        .Add Part
        .Paste
    End With
    With Part.HybridBodies
        Set CopyPasteHybridBody = .Item(.Count)
    End With
End Function

'平面の選択
Private Function SelectPlanarFace() As Reference
    Dim FilterType(0)  As Variant
    FilterType(0) = "PlanarFace"
    Call SelectItem(FilterType, "対称基準となる平面を選択して下さい / ESCｷｰ ｷｬﾝｾﾙ")
    Set SelectPlanarFace = Part.CreateReferenceFromBRepName( _
                    GetBrepName(sel.Item(1).Value.Name), sel.Item(1).Value.Parent)
End Function

'SelectElement用BrapName取得
Private Function GetBrepName(MyBRepName As String) As String
    MyBRepName = Replace(MyBRepName, "Selection_", "")
    MyBRepName = Left(MyBRepName, InStrRev(MyBRepName, "));"))
    MyBRepName = MyBRepName + ");WithPermanentBody;WithoutBuildError;WithSelectingFeatureSupport;MFBRepVersion_CXR15)"
    GetBrepName = MyBRepName
End Function

'形状ｾｯﾄ選択
Private Function SelectHybridBody() As HybridBody
    Dim FilterType(0)  As Variant
    FilterType(0) = "HybridBody"
    Call SelectItem(FilterType, "元となる形状ｾｯﾄを選択して下さい / ESCｷｰ ｷｬﾝｾﾙ")
    Set SelectHybridBody = sel.Item(1).Value
End Function

'選択
Private Sub SelectItem(FilterType As Variant, Msg As String)
    sel.Clear
    If sel.SelectElement2(FilterType, Msg, False) = "Cancel" Then End
End Sub

SymmetryItem関数を修正し、GetColor関数、SetColor関数の2個を追加
しました。