二つのﾎﾞﾃﾞｨ/形状ｾｯﾄを比較して、差分を抽出する

前回のﾏｸﾛでは、2つを比較して色を反映させましたが、

同一の面を認識＝異なる面を認識

なので、2つを比較して異なる面を抽出するﾏｸﾛを作りました。

'vba sample_GetChangeArea_ver0.01  using-'KCL0.08'
'2つのﾎﾞﾃﾞｨ/形状ｾｯﾄの異なる面を抽出
Option Explicit

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

Const CogTolSqr = CogTolerance * CogTolerance

Sub CATMain()
    'ﾄﾞｷｭﾒﾝﾄのﾁｪｯｸ
    If Not CanExecute(Array("PartDocument", "ProductDocument")) Then Exit Sub
    
    '対象ﾎﾞﾃﾞｨ選択
    Dim Msg$: Msg = "ﾁｪｯｸするﾎﾞﾃﾞｨ/形状ｾｯﾄを選択して下さい : ESCｷｰ 終了"
    Dim TgtBody As AnyObject: Set TgtBody = KCL.SelectItem(Msg, "Body,HybridBody")
    If KCL.IsNothing(TgtBody) Then Exit Sub
    Dim TgtCount&: TgtCount = SearchTopoFaces(TgtBody)
    If TgtCount < 1 Then
        MsgBox TgtBody.Name + " に面が有りません!"
        Exit Sub
    End If
    
    '参照ﾎﾞﾃﾞｨ選択
    Msg = "比較するﾎﾞﾃﾞｨ/形状ｾｯﾄを選択して下さい : ESCｷｰ 終了"
    Dim RefBody As AnyObject: Set RefBody = KCL.SelectItem(Msg, "Body,HybridBody")
    If KCL.IsNothing(RefBody) Then Exit Sub
    Dim RefCount&: RefCount = SearchTopoFaces(RefBody)
    If RefCount < 1 Then
        MsgBox RefBody.Name + " に面が有りません!"
        Exit Sub
    End If
    
    '確認
    Msg = TgtBody.Name + "(" + CStr(TgtCount + 1) + "枚)の変更箇所を" + vbNewLine + _
          RefBody.Name + "(" + CStr(RefCount + 1) + "枚)を元に" + vbNewLine + _
          "確認しますか?"
    If MsgBox(Msg, vbYesNo) = vbNo Then Exit Sub
    
    KCL.SW_Start
    
    '対象ﾎﾞﾃﾞｨ ﾘﾌｧﾚﾝｽ取得
    Dim TgtRefs As Variant: TgtRefs = GetTopoFacesRef(TgtBody)
    If IsEmpty(TgtRefs) Then Exit Sub
    
    '対象ﾎﾞﾃﾞｨ ﾄﾎﾟﾛｼﾞ情報取得
    Dim TgtGeos As Variant:  TgtGeos = GetGeoInfo(TgtBody, TgtRefs)
    
    '参照ﾎﾞﾃﾞｨ ﾘﾌｧﾚﾝｽ取得
    Dim RefRefs As Variant: RefRefs = GetTopoFacesRef(RefBody)
    If IsEmpty(RefRefs) Then Exit Sub
    
    '参照ﾎﾞﾃﾞｨ ﾄﾎﾟﾛｼﾞ情報取得
    Dim RefGeos As Variant:  RefGeos = GetGeoInfo(RefBody, RefRefs)
    
    '差分ｲﾝﾃﾞｯｸｽ取得
    Dim DifIdxs As Variant: DifIdxs = GetDifference(TgtGeos, RefGeos)
    If IsEmpty(DifIdxs) Then
        MsgBox "'" + TgtBody.Name + "' と '" + RefBody.Name + "' " + vbNewLine + _
               "の違いは見つかりませんでした"
        Exit Sub
    End If
    
    '差分面作成
    Call ExtractFace(TgtBody, TgtRefs, DifIdxs)
    
    '終了
    Debug.Print KCL.SW_GetTime
    MsgBox CStr(UBound(DifIdxs) + 1) + "枚分の違いを作成しました"
End Sub

'差分面作成
Private Sub ExtractFace(ByVal ParentOj As AnyObject, ByRef Refs As Variant, ByVal Idx As Variant)
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(ParentOj, "PartDocument")
    Dim Pt As Part: Set Pt = Doc.Part
    
    CATIA.HSOSynchronized = False
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    
    Dim Ref As Reference
    Set Ref = Pt.CreateReferenceFromBRepName(KCL.GetBrepName(Refs(Idx(0)).DisplayName), Refs(Idx(0)).Parent)
    
    Dim Exts As HybridShapeExtractMulti: Set Exts = Fact.AddNewExtractMulti(Ref)
    Dim i&, j&
    For i = 0 To UBound(Idx)
        Set Ref = Pt.CreateReferenceFromBRepName(KCL.GetBrepName(Refs(Idx(i)).DisplayName), Refs(Idx(i)).Parent)
        j = i + 1
        With Exts
            .AddConstraintTolerant Ref, 3, False, False, 0.01, 0.5, 0.98, j
            .SetElement j, Ref
            .SetPropagationType i + 1, 3
            .SetComplementaryExtractMulti j, False
            .SetIsFederated j, False
            .SetDistanceThresholdActivity j, False
            .SetAngularThresholdActivity j, False
            .SetCurvatureThresholdActivity j, False
        End With
    Next
    Pt.UpdateObject Exts
    Dim HB As HybridBody: Set HB = Doc.Part.HybridBodies.Add()
    HB.Name = "Change_Area"
    Set Ref = Pt.CreateReferenceFromObject(Exts)
    Dim Exp As HybridShapeSurfaceExplicit: Set Exp = Fact.AddNewSurfaceDatum(Ref)
    HB.AppendHybridShape Exp
    Call SetGraphicProperty(Doc.Selection, Exp)
    Pt.UpdateObject Exp
    Fact.DeleteObjectForDatum Ref
    CATIA.HSOSynchronized = True
End Sub

'色等設定
Private Sub SetGraphicProperty(ByRef Sel As Selection, ByVal Face As Variant)
    Dim VPS As VisPropertySet: Set VPS = Sel.VisProperties
    CATIA.HSOSynchronized = False
    Sel.Clear
    Sel.Add Face
    VPS.SetRealColor 255, 0, 0, 1
    VPS.SetRealWidth 4, 1
    Sel.Clear
    CATIA.HSOSynchronized = True
End Sub

'差分検索 return-異なるIdx
Private Function GetDifference(ByRef TgtGeos As Variant, ByRef RefGeos As Variant) As Variant
    Dim Cnt&: Cnt = UBound(TgtGeos)
    Dim UnHit() As Variant: ReDim UnHit(Cnt)
    Dim UnHitCnt&: UnHitCnt = -1
    Dim i&, j&, HitFg As Boolean
    
    For i = 0 To Cnt
        HitFg = False
        For j = 0 To UBound(RefGeos)
            If IsGeoEqual(TgtGeos(i), RefGeos(j)) Then
                HitFg = True
                Exit For
            End If
        Next
        If Not HitFg Then
            UnHitCnt = UnHitCnt + 1
            UnHit(UnHitCnt) = i
        End If
    Next
    
    If UnHitCnt < 0 Then Exit Function
    ReDim Preserve UnHit(UnHitCnt)
    GetDifference = UnHit
End Function

'Geo一致
Private Function IsGeoEqual(ByVal P1 As Variant, ByVal P2 As Variant) As Boolean
    IsGeoEqual = False
    If IsCogEqual(P1, P2) And IsAreaEqual(P1, P2) Then IsGeoEqual = True
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

'CogとAreaの取得
'0-CogX 1-CogY 2-CogZ 3-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
    If SearchTopoFaces(AnyOj) < 1 Then Exit Function
    
    Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(AnyOj, "PartDocument")
    Dim Sel As Selection: Set Sel = Doc.Selection
    Dim Refs() As Reference: ReDim Refs(Sel.Count2 - 1)
    Dim i&
    For i = 0 To Sel.Count2 - 1
        Set Refs(i) = Sel.Item(i + 1).Reference
    Next
    GetTopoFacesRef = Refs
End Function

'topologyのFaceの検索
Private Function SearchTopoFaces(ByVal AnyOj As AnyObject) As Long
    Dim Sel As Selection: Set Sel = KCL.GetParent_Of_T(AnyOj, "PartDocument").Selection
    CATIA.HSOSynchronized = False
    With Sel
        .Clear
        .Add AnyOj
        .Search "Topology.CGMFace,sel"
    End With
    CATIA.HSOSynchronized = True
    SearchTopoFaces = Sel.Count2
End Function

前回同様、各面の重心と表面積で判断しています。

今回は、Referenceに手間取りました。
重心と表面積を取得する際と、抽出面を作成する際に必要だったのですが
同じReferenceじゃNGだったんです。

・重心と表面積 - Selection.Item(1).Reference のﾀｲﾌﾟを使用
・抽出面を作成 - Part.CreateReferenceFromBRepName のﾀｲﾌﾟを使用

過去にこれをやっていたのでわかりましたが、
SelectElementからReferenceの取得 - C#ATIA
知らなきゃ途中で諦めていたかも。

又、ﾏｸﾛ使用後はCATDUAを実行する事をお勧めします。
以前は気が付かなかったのですが、CreateReferenceFromBRepNameを利用して
Referenceを取得すると、どうしても1個だけｺﾞﾐが出来上がるようで
防ぐ事ができませんでした。　行わなくても問題は無いとは思いますが。

実際に試した感じです。

f:id:kandennti:20161124172853p:plain

こんな感じのﾃﾞｰﾀで試します。　念の為ですが、GrabCADで拾ってきたデータです。
片方はFusion360で一部変更しました。　ﾀﾞｲﾚｸﾄﾓｰﾄﾞだと不要な面を選択し
Deleteｷｰでｼﾞｬﾝｼﾞｬﾝ削除出来るんですよ。　(操作が直感的)
CATIAは厳密に面を選択しないとｴﾗｰになりますが、Fusion360の場合は、ある程度
判断して削除してくれるので、遥かに効率良いです。

まず変更後のﾎﾞﾃﾞｨ又は形状ｾｯﾄを選択し、続いて比較するﾎﾞﾃﾞｨ/形状ｾｯﾄを
選択します。処理前にこんな感じのﾀﾞｲｱﾛｸﾞが出現します。

f:id:kandennti:20161124173521p:plain