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

こちらの続きです。
http://kantoku.hatenablog.com/entry/2016/11/24/173743
http://kantoku.hatenablog.com/entry/2017/07/19/190425

原因を突き止め切れていないのですが、結果が総当りと
一致するようになりました。

まずは、本ﾏｸﾛのｴﾝﾄﾘｰﾎﾟｲﾝﾄを持つ標準ﾓｼﾞｭｰﾙ "GetChangeArea.bas"
です。

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

'*** 設定値 ***
Const COGTOLERANCE = 0.001                  '同一判断重心距離
Const AREATOLERANCE = 0.01                  '同一判断面積

Const RESULT_COLOR = "255, 0, 0"            '抽出後色
Const RESULT_WIDTH = 4                      '抽出後幅
'**************

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) + "枚)の変更箇所を" + vbNewLine + _
          RefBody.Name + "(" + CStr(RefCount) + "枚)を元に" + 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, TgtBody.Name & "-" & RefBody.Name)
    
    '終了
    Debug.Print CStr(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, ByVal HBName As String)
    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)
        Exts.AddConstraintTolerant Ref, 3, False, False, 0.01, 0.5, 0.98, i + 1
    Next
    Pt.UpdateObject Exts
    Dim Hb As HybridBody: Set Hb = Doc.Part.HybridBodies.Add()
    Hb.Name = HBName & "_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
    Dim AryRGB As Variant
    AryRGB = Split(RESULT_COLOR, ",")
    
    CATIA.HSOSynchronized = False
    Sel.Clear
    Sel.Add Face
    VPS.SetRealColor AryRGB(0), AryRGB(1), AryRGB(2), 1
    VPS.SetRealWidth RESULT_WIDTH, 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) + UBound(RefGeos)
    Dim UnHit() As Variant: ReDim UnHit(Cnt)
    Dim UnHitCnt&: UnHitCnt = -1
    Dim i&, j&, k&, HitFg As Boolean
    
    Dim CombAry As Variant
    CombAry = GetCombinationAry(TgtGeos, RefGeos)
    
    For i = 0 To UBound(CombAry)
        For j = 0 To UBound(CombAry(i)(0))
            HitFg = False
            For k = 0 To UBound(CombAry(i)(1))
                If IsGeoEqual(TgtGeos(CombAry(i)(0)(j)), RefGeos(CombAry(i)(1)(k))) Then
                    HitFg = True
                    Exit For
                End If
            Next
            If HitFg = False Then
                UnHitCnt = UnHitCnt + 1
                UnHit(UnHitCnt) = CombAry(i)(0)(j)
            End If
        Next
    Next
    
    If UnHitCnt < 0 Then Exit Function
    ReDim Preserve UnHit(UnHitCnt)
    GetDifference = UnHit
End Function

'組み合わせ-8分木ﾗｲﾌﾞﾗﾘ利用
Private Function GetCombinationAry(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Variant ' Collection
    Dim Lst As Collection: Set Lst = ToList(Ary1, Ary2)
    Dim SplitCnt As Long: SplitCnt = UBound(Ary1) + 1
    
    Dim OctLst As Collection
    Set OctLst = GetChangeArea_Oct.GetLinerOctreeList(Lst, COGTOLERANCE, 50)
    
    Dim CombAry() As Variant: ReDim CombAry(OctLst.Count - 1)
    Dim Space As Collection, Idx As Variant
    Dim Lst1 As Collection, Lst2 As Collection
    Dim Cnt As Long: Cnt = -1
    For Each Space In OctLst
        Set Lst1 = New Collection
        Set Lst2 = New Collection
        For Each Idx In Space
            If Idx < SplitCnt + 1 Then
                Lst1.Add Idx - 1
            Else
                Lst2.Add Idx - SplitCnt - 1
            End If
        Next
        Cnt = Cnt + 1
        CombAry(Cnt) = Array(ToAry(Lst1), ToAry(Lst2))
    Next
    GetCombinationAry = CombAry
End Function

'ｺﾚｸｼｮﾝ配列化
Private Function ToAry(ByVal Lst As Collection) As Variant
    If Lst.Count < 1 Then
        ToAry = Array()
        Exit Function
    End If
    Dim Ary() As Variant: ReDim Ary(Lst.Count - 1)
    Dim i As Long
    
    For i = 1 To Lst.Count
        Ary(i - 1) = Lst.Item(i)
    Next
    ToAry = Ary
End Function

'二つの配列を連結しｺﾚｸｼｮﾝ化
Private Function ToList(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Collection
    Dim Lst As Collection: Set Lst = New Collection
    Dim i As Long
    
    For i = 0 To UBound(Ary1)
        Lst.Add Ary1(i)
    Next
    For i = 0 To UBound(Ary2)
        Lst.Add Ary2(i)
    Next
    Set ToList = Lst
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(3) As Variant, i&, Mes As Variant 'Measurable
    
    For i = 0 To UBound(Infos)
        Set Mes = SPA.GetMeasurable(Refs(i))
        Mes.GetCOG Cog
        Cog(3) = Mes.Area
        Infos(i) = Cog
    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

続いて、我流8分木ﾗｲﾌﾞﾗﾘ標準ﾓｼﾞｭｰﾙ "GetChangeArea_Oct.bas" です。

'vba GetChangeArea_Oct.bas Ver0.0.1  using-'KCL0.0.10'
'ﾓｰﾄﾝ順序を利用した8分木空間分割ﾗｲﾌﾞﾗﾘ
'GetChangeAreaﾏｸﾛ専用です

Option Explicit

Private Const CLINER8TREEMANAGER_MAXLEVEL = 7   '有効空間分割最大ﾚﾍﾞﾙ

Private m_Level&                                '分割ﾚﾍﾞﾙ
Private m_Tolerance#                            '一致ﾄﾚﾗﾝｽ
Private m_MaxCount&                             '同一空間内最大数(目安)
Private m_AxisCount&                            '空間分割時の各軸の最大数
Private m_MinPos                                '空間最小座標
Private m_Unit                                  '空間単位ｻｲｽﾞ
Private m_ToleranceRatio                        '空間単位ｻｲｽﾞに対してのﾄﾚﾗﾝｽ比率
Private m_CellCount&()                          'ﾚﾍﾞﾙ毎の空間数

'*** Octree ***
'http://marupeke296.com/COL_3D_No15_Octree.html

'線形8分木ﾘｽﾄ取得
''' @param :Pnts-Collection(array(Double))-座標値郡
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Collection(Collection(long))-空間別点Idx郡
Function GetLinerOctreeList(ByVal Pnts As Collection, ByVal Tolerance#, ByVal MAXCOUNT&)
    Set GetLinerOctreeList = Nothing
    
    '座標値郡のIdxList作成
    Dim PntIdxList As Collection: Set PntIdxList = InitRangeList(Pnts.Count)
    
    '空間内最大数以下の場合、そのまま返す
    Dim DecidedList As Collection: Set DecidedList = New Collection
    If Pnts.Count < MAXCOUNT Then
        Call DecidedList.Add(PntIdxList)
        GoTo FuncEnd
    End If
    
    '初期設定
    If Not SetStart(Tolerance, MAXCOUNT) Then
        MsgBox "設定値が不正です"
        Exit Function
    End If
    
    'IdxListをﾙｰﾄ空間として登録
    Dim CheckList As Collection: Set CheckList = New Collection
    Call CheckList.Add(PntIdxList)
    
    'ﾚﾍﾞﾙの応じたIdx用配列
    Dim SpeceEnum, TempList As Collection, ReCheckList As Collection
    Dim Space, TempSpace, SpaAry, i&, Idx
    Do
        Set ReCheckList = New Collection
        '配置
        For Each Space In CheckList
            If Not SetSpaceInfo(Pnts, Space) Then '空間が小さすぎる
                Call DecidedList.Add(Space)
                GoTo continue
            End If
            
            SpeceEnum = InitRangeAry(m_CellCount(m_Level), -1)
            Set TempList = New Collection
            
            For Each Idx In Space
                SpaAry = GetMortonNum(Pnts(Idx))
                For i = 0 To UBound(SpaAry)
                    If SpeceEnum(SpaAry(i)) < 0 Then
                        Call TempList.Add(InitSpace())
                        SpeceEnum(SpaAry(i)) = TempList.Count
                    End If
                    Call TempList.Item(SpeceEnum(SpaAry(i))).Add(Idx)
                Next
            Next
            
            '空間毎の数が多いものを再配置
            For Each TempSpace In TempList
                Select Case True
                    Case TempSpace.Count < 2
                        Call DecidedList.Add(TempSpace)
                    Case TempSpace.Count > m_MaxCount
                        Call ReCheckList.Add(TempSpace)
                    Case Else
                        Call DecidedList.Add(TempSpace)
                End Select
            Next
continue:
        Next
        If ReCheckList.Count < 1 Then Exit Do
        Set CheckList = ReCheckList
    Loop
    
FuncEnd:
    Call Q_ISort_List(DecidedList)
    Set GetLinerOctreeList = DecidedList
    Set PntIdxList = Nothing
    Set DecidedList = Nothing
    Set CheckList = Nothing
    Set ReCheckList = Nothing
    Set TempList = Nothing
    ReDim SpeceEnum(0)
End Function

'空のｺﾚｸｼｮﾝ
Private Function InitSpace() As Collection
    Set InitSpace = New Collection
End Function

'線形8分木準備
''' @param :Level-long-分割ﾚﾍﾞﾙ
''' @param :Tolerance-Double-一致ﾄﾚﾗﾝｽ
''' @param :MaxCount-long-同一空間内最大数(目安)
''' @return:Boolean
Private Function SetStart(ByVal Tolerance#, ByVal MAXCOUNT&) As Boolean
    SetStart = False
    If Tolerance <= 0 Then Exit Function
    
    m_Tolerance = Tolerance
    m_MaxCount = MAXCOUNT
    m_ToleranceRatio = InitRangeAry(2, 0)
    
    ReDim m_CellCount(CLINER8TREEMANAGER_MAXLEVEL + 1)
    m_CellCount(0) = 1
    Dim i&
    For i = 1 To UBound(m_CellCount)
        m_CellCount(i) = m_CellCount(i - 1) * 8
    Next
    SetStart = True
End Function

'空間ｻｲｽﾞとﾄﾚﾗﾝｽからﾚﾍﾞﾙ算出し設定
Private Function SetLevel(ByVal W) As Boolean
    SetLevel = False
    Dim Min#: Min = 1.79769313486231E+308
    Dim i&
    For i = 0 To 2
         If Min > W(i) Then Min = W(i)
    Next
    Dim TmpLv&: TmpLv = Fix(Log_n((Min / (m_Tolerance * 2 + 0.002)), 2))
    If TmpLv > CLINER8TREEMANAGER_MAXLEVEL Then
        m_Level = CLINER8TREEMANAGER_MAXLEVEL
    Else
        m_Level = TmpLv
    End If
    
    If m_Level < 1 Then Exit Function
    m_AxisCount = sl(1, m_Level)
    SetLevel = True
End Function

'空間情報設定
''' @param :Pnts-Collection(array(Double))-座標値郡
''' @param :Idxs-Collection(long)-座標値郡Idx
''' @return:Boolean
Private Function SetSpaceInfo(ByVal Pnts, ByVal idxs As Collection) As Boolean
    SetSpaceInfo = False
    Dim SpSize: SpSize = GetSpaceSize_Idx(Pnts, idxs)
    m_MinPos = AryAdd(SpSize(0), m_Tolerance * -2)
    Dim W: W = ArySub(AryAdd(SpSize(1), m_Tolerance * 2 + 0.002), m_MinPos)
    If Not SetLevel(W) Then Exit Function
    m_Unit = AryDiv(W, m_AxisCount)
    
    Dim i&
    For i = 0 To 2
        m_ToleranceRatio(i) = m_ToleranceRatio(i) / m_Unit(i)
    Next
    SetSpaceInfo = True
End Function

'座標→最小ﾚﾍﾞﾙ空間番号郡取得
''' @param :Pos-array(Double)-座標値
''' @return:array(Long)
Private Function GetMortonNum(ByVal pos As Variant) As Variant
    Dim Ratio#(2), Inte&(2), Dec#(2)
    Dim i&
    For i = 0 To 2
        Ratio(i) = (pos(i) - m_MinPos(i)) / m_Unit(i)
        Inte(i) = Fix(Ratio(i))
        Dec(i) = Ratio(i) - Inte(i)
    Next
    
    Dim Axis(2) As Variant
    Dim AxisNums As Collection
    For i = 0 To 2
        Set AxisNums = New Collection
        AxisNums.Add Inte(i)
        If Dec(i) <= m_ToleranceRatio(i) And Inte(i) > 0 Then AxisNums.Add Inte(i) - 1
        If 1# - Dec(i) <= m_ToleranceRatio(i) And Inte(i) < m_AxisCount - 1 Then AxisNums.Add Inte(i) + 1
        Set Axis(i) = AxisNums
    Next
    
    Dim x, y, z
    Dim SpaNo(): ReDim SpaNo(Axis(0).Count * Axis(1).Count * Axis(2).Count)
    Dim Cnt&: Cnt = -1
    For Each x In Axis(0)
        For Each y In Axis(1)
            For Each z In Axis(2)
                Cnt = Cnt + 1
                SpaNo(Cnt) = Get3DMortonNumber(x, y, z)
                If SpaNo(Cnt) < 0 And SpaNo(Cnt) >= m_CellCount(m_Level) Then Cnt = Cnt - 1
    Next: Next: Next
    ReDim Preserve SpaNo(Cnt)
    GetMortonNum = SpaNo
End Function

'ビット分割関数
''' @param :n-long
''' @return:long
Private Function BitSeparateFor3D(ByVal n&) As Long
    Dim s As Long: s = n
    s = (s Or sl(s, 8)) And &HF00F
    s = (s Or sl(s, 4)) And &HC30C3
    s = (s Or sl(s, 2)) And &H249249
    BitSeparateFor3D = s
End Function

'8分木モートン順序算出関数
''' @param :x-long
''' @param :y-long
''' @param :z-long
''' @return:long
Private Function Get3DMortonNumber(ByVal x&, ByVal y&, ByVal z&) As Long
   Get3DMortonNumber = BitSeparateFor3D(x) Or _
                       sl(BitSeparateFor3D(y), 1) Or _
                       sl(BitSeparateFor3D(z), 2)
End Function

'座標値郡から空間ｻｲｽﾞ取得
''' @param :EndPnts-Collection(array(Double))-座標値郡
''' @return:array(array(Double))-0:最小値 1:最大値
Private Function GetSpaceSize_Idx(ByVal EndPnts As Collection, ByVal IdxList As Collection) As Variant
    Dim Min: Min = InitRangeAry(2, 1.79769313486231E+308)
    Dim Max: Max = InitRangeAry(2, -1.79769313486231E+308)
    
    Dim Idx, i&
    For Each Idx In IdxList
        For i = 0 To 2
            If Min(i) > EndPnts.Item(Idx)(i) Then Min(i) = EndPnts.Item(Idx)(i)
            If Max(i) < EndPnts.Item(Idx)(i) Then Max(i) = EndPnts.Item(Idx)(i)
        Next
    Next
    GetSpaceSize_Idx = Array(Min, Max)
End Function

'*** BitShift ***
'http://www.geocities.co.jp/SiliconValley/4334/unibon/asp/bitshift2.html
' 左シフト
Private Function sl(ByVal x&, ByVal n&) As Long
    If n = 0 Then
        sl = x
    Else
        Dim k: k = CLng(2 ^ (32 - n - 1))
        Dim D: D = x And (k - 1)
        Dim c: c = D * CLng(2 ^ n)
        If x And k Then c = c Or &H80000000
        sl = c
    End If
End Function

'*** VBA不足関数 ***
'配列同士の引き算-細かいチェック無し
Private Function ArySub(ByVal a, ByVal b) As Variant
    ArySub = Array(a(0) - b(0), a(1) - b(1), a(2) - b(2))
End Function

'配列と実数の足し算-細かいチェック無し
Private Function AryAdd(ByVal a, ByVal b#) As Variant
    AryAdd = Array(a(0) + b, a(1) + b, a(2) + b)
End Function

'配列と実数の割り算-細かいチェック無し
Private Function AryDiv(ByVal a, ByVal b#) As Variant
    AryDiv = Array(a(0) / b, a(1) / b, a(2) / b)
End Function

'初期化済み配列生成 - ｵﾌﾞｼﾞｪｸﾄNG
Private Function InitRangeAry(ByVal Count&, ByVal Value As Variant)
    Dim Ary() As Variant: ReDim Ary(Count)
    Dim i&
        For i = 0 To Count
            Ary(i) = Value
        Next
    InitRangeAry = Ary
End Function

'初期化済みｺﾚｸｼｮﾝ生成
Private Function InitRangeList(ByVal Count&) As Collection
    Dim List As Collection: Set List = New Collection
    Dim i&
    For i = 1 To Count
        List.Add i
    Next
    Set InitRangeList = List
End Function

'ｺﾚｸｼｮﾝｶｳﾝﾀによるｸｲｯｸｿｰﾄ　非再帰版
'https://foolexp.wordpress.com/2011/10/29/%E3%82%AF%E3%82%A4%E3%83%83%E3%82%AF%E3%82%BD%E3%83%BC%E3%83%88%E3%81%A8%E6%8C%BF%E5%85%A5%E3%82%BD%E3%83%BC%E3%83%88%E3%81%AE%E3%83%8F%E3%82%A4%E3%83%96%E3%83%AA%E3%83%83%E3%83%89/
'http://ufcpp.net/study/algorithm/sort_quick.html
'http://thom.hateblo.jp/entry/2015/11/29/212934
Private Sub Q_ISort_List(ByRef List As Collection)
    Dim THREASHOLD&: THREASHOLD = 64
    Dim Stack As Collection: Set Stack = New Collection
    Stack.Add 1, CStr(Stack.Count + 1)
    Stack.Add List.Count, CStr(Stack.Count + 1)
    
    Dim Pivot, Temp1, Temp2
    Dim LeftIdx&, RightIdx&, i&, j&
    Do While Stack.Count > 0
        LeftIdx = Stack(CStr(Stack.Count - 1))
        RightIdx = Stack(CStr(Stack.Count))
        Stack.Remove Stack.Count
        Stack.Remove Stack.Count
        'クイックソート
        If LeftIdx < RightIdx Then
            Set Pivot = List((LeftIdx + RightIdx) / 2)
            i = LeftIdx
            j = RightIdx
            
            Do While i <= j
                Do While List(i).Count < Pivot.Count
                    i = i + 1
                Loop
                Do While List(j).Count > Pivot.Count
                    j = j - 1
                Loop
                If i <= j Then
                    Set Temp1 = List(i)
                    Set Temp2 = List(j)
                    List.Add Temp1, After:=j
                    List.Remove j
                    List.Add Temp2, After:=i
                    List.Remove i
                    i = i + 1
                    j = j - 1
                End If
            Loop
            
            If RightIdx - i >= 0 Then
                If RightIdx - i <= THREASHOLD Then
                    ComboInsertionSort List, i, RightIdx
                Else
                    Stack.Add i, CStr(Stack.Count + 1)
                    Stack.Add RightIdx, CStr(Stack.Count + 1)
                End If
            End If
            
            If j - LeftIdx >= 0 Then
                If j - LeftIdx <= THREASHOLD Then
                    ComboInsertionSort List, LeftIdx, j
                Else
                    Stack.Add LeftIdx, CStr(Stack.Count + 1)
                    Stack.Add j, CStr(Stack.Count + 1)
                End If
            End If
        End If
    Loop
End Sub

'InsertSort
Private Sub ComboInsertionSort(ByRef List, ByVal MinIdx&, ByVal MaxIdx&)
    Dim Temp1, Temp2
    Dim i&, j&: j = 1
    For j = MinIdx To MaxIdx
        i = j - 1
        Do While i >= 1
            If List(i + 1).Count < List(i).Count Then
                Set Temp1 = List(i + 1)
                Set Temp2 = List(i)
                List.Add Temp2, After:=i + 1
                List.Remove i + 1
                List.Add Temp1, After:=i
                List.Remove i
            Else
                Exit Do
            End If
            i = i - 1
        Loop
    Next
End Sub

'nを底とする対数
Private Function Log_n(x, n)
    Log_n = Log(x) / Log(n)
End Function

以上の2つとKCLを、同一ﾌﾟﾛｼﾞｪｸﾄ内としておいて下さい。

ﾃｽﾄ結果です。

〇2884枚-2866枚　抽出面178枚
ver0.0.1:39.825秒
ver0.0.2:13.909秒

〇2871枚-2199枚　抽出面1388枚
ver0.0.1:46.117秒
ver0.0.2:33.396秒

8分木の効果は出ていますが、もう少し効果が出るかと
期待していたのですが･･･。

ﾊﾞｯﾁ処理前にﾏｸﾛでﾓﾃﾞﾙをﾁｪｯｸする

久々にPowerMillのﾏｸﾛです。　かなり忘れています。

PowerMillで苦労している部分は多々あるのですが、
一番精神的にﾀﾞﾒｰｼﾞを受けるのが、ﾓﾃﾞﾙのｲﾝﾎﾟｰﾄ。

お互いｲﾛｲﾛとﾗｲｾﾝｽが無い為、Igesで受け渡しを行っています。
どうやら苦労されているのは、僕だけではなく･･･
http://www.coe.org/p/fo/et/thread=29121
Stepでも面が抜け落ちたりしているようです。
(解決されたみたいですが)

時間のかかる処理を行った後に、
「あっここの小さな面が抜けてる･･･」
となると、途端にﾓﾁﾍﾞｰｼｮﾝが下がりまくります。
(でも、どのCAMｿﾌﾄでも経験があるはず)

事前にﾃﾞｰﾀをﾁｪｯｸし修復さえしていれば、かなりｽﾄﾚｽ軽減に
なるはずなので、ﾏｸﾛで処理してしまいます。

//pm2018 macro
//Find_Surface_Clearance.mac Ver0.0.2
//ﾓﾃﾞﾙの隙間とﾊﾞｯﾄﾞｻｰﾌｪｽの検索

function Main() {
	real MeshTolDef = 0.005 //ﾒｯｼｭﾄﾚﾗﾝｽ-ﾃﾞﾌｫﾙﾄ
	real ClearTolDef= 0.1 //隙間ﾄﾚﾗﾝｽ-ﾃﾞﾌｫﾙﾄ
	
	//**ﾕｰｻﾞｰ選択**
	//ﾓﾃﾞﾙ
	string msg = '隙間と不良面をﾁｪｯｸするﾓﾃﾞﾙを選択してください'
	string list models = input entity multiple model $msg
	if is_empty(models) {
		return
	}
	
	//ｻｰﾌｪｽ方向
	$msg = 'ｻｰﾌｪｽ方向処理を行いますか?'
	bool NormalFg= 0
	$NormalFg= QUERY $msg
	
	//ﾒｯｼｭﾄﾚﾗﾝｽ
	$msg = '不良面ﾁｪｯｸﾄﾚﾗﾝｽを入力して下さい'	
	real MeshTol = $MeshTolDef 
	call InputReal($Msg, $MeshTolDef , $MeshTol )
	if $MeshTol  < 0 {
		return
	}	
	
	//隙間ﾄﾚﾗﾝｽ
	$msg = '隙間ﾁｪｯｸﾄﾚﾗﾝｽを入力して下さい'	
	real ClearTol  = $ClearTolDef
	call InputReal($Msg, $ClearTolDef , $ClearTol )
	if $ClearTol   < 0 {
		return
	}

	//**処理**
	call DialogOff()
	
	//ｻｰﾌｪｽ方向
	if $NormalFg {
		call Exec_OrientNormals($models)
	} 
	
	//BadSurfaces
	call Exec_BadSurfaces($models, $MeshTol) 
	
	//ﾊﾞｳﾝﾀﾞﾘ作成
	call Create_Boundary($models , $ClearTol ) 
	
	call DialogOn()
	message info 'Done'
}

//不良面
function Exec_BadSurfaces(string list Models, real Tol) {
	EDIT MODEL ALL DESELECT ALL
	foreach name in $Models {
		EDIT MODEL $name SELECT ALL
	}	
	
	string nxtset = new_entity_name('Level')
	CREATE LEVEL ; MODELCOMPSET
	EDIT LEVEL $nxtset ACQUIRE SELECTED
	string cmd = 'EDIT LEVEL $nxtset MESH "' + string($Tol) +'"'
	DoCommand $cmd
	DELETE LEVEL $nxtset
	
	EDIT MODEL ALL DESELECT ALL	
	VIEW MODEL ; SHADE NORMAL
}

//ｻｰﾌｪｽ方向
function Exec_OrientNormals(string list Models) {
	EDIT MODEL ALL DESELECT ALL
	foreach name in $Models {
		EDIT MODEL $name SELECT ALL
		EDIT MODEL $name ORIENT_NORMALS SELECTED
	}	
}

//ﾊﾞｳﾝﾀﾞﾘ
function Create_Boundary(string list Models, real Tol ) {
	EDIT MODEL ALL DESELECT ALL
	string newname = ''
	foreach name in $Models {
		EDIT MODEL $name SELECT ALL
		$newname = $newname + $name + '_' 
	}	
	$newname = $newname + '_Checked-Tol_' + string($Tol)
	
	string Bouname = new_entity_name('Boundary')
	CREATE BOUNDARY ; SKETCH FORM BOUNDARY
	EDIT BOUNDARY $Bouname TOLERANCE $Tol
	EDIT BOUNDARY $Bouname INSERT MODEL
	
	RENAME BOUNDARY $Bouname $newname
	
	EDIT BOUNDARY $newname ACCEPT BOUNDARY ACCEPT
	EDIT MODEL ALL DESELECT ALL
}

//数値入力 不正時は-1を返す
function InputReal(string Msg, real Defreal, output real  Outreal) {
	$Outreal = -1
	real res = $Defreal
	$res = input $Msg
	bool err = 0
	$err = error $res
	if $err {
		message error '数値を入力して下さい!'
		return
	} 
	if $res <=0 {
		message error '0以上の数値を入力して下さい!'
		return
	} 	
	$Outreal = $res
}

//ﾀﾞｲｱﾛｸﾞ類ｵﾝ
function DialogOn() {
	GRAPHICS UNLOCK
	DIALOGS MESSAGE ON
	DIALOGS ERROR ON
	ECHO ON DCPDEBUG TRACE COMMAND ACCEPT
}

//ﾀﾞｲｱﾛｸﾞ類ｵﾌ
function DialogOff() {
	GRAPHICS LOCK
	DIALOGS MESSAGE OFF
	DIALOGS ERROR OFF
	ECHO OFF DCPDEBUG UNTRACE COMMAND ACCEPT
}

ﾏｸﾛ実行後
・対象ﾓﾃﾞﾙの選択
・ｻｰﾌｪｽの方向付け(任意)
・ﾒｯｼｭﾄﾚﾗﾝｽ入力
・隙間ﾄﾚﾗﾝｽ入力
で自動的に、BadSurfcesの検出と隙間となるﾊﾞｳﾝﾀﾞﾘを作成します。
(BadSurfcesは処理上で弊害となる不正面で、存在しているとﾂｰﾙﾊﾟｽを
　計算してくれません)

実際に試した感じです。

最初はﾓﾃﾞﾙの色がｸﾞﾚｰと茶色が整っていないのですが、
ﾏｸﾛ内で処理させています･･･が、最後にｽﾞｰﾑさせた位置に
反転した面があるんですよね。（完全じゃないです）

差分を抽出ﾏｸﾛ修正中

こちらの続きです。
ﾏｸﾛを直したい(愚痴) - C#ATIA

少しづつ時間が確保出来たので、修正しているのですが･･･。
こちらのﾏｸﾛの問題点は、互いの面を総当りで比較している
と言う点です。
二つのﾎﾞﾃﾞｨ/形状ｾｯﾄを比較して、差分を抽出する - C#ATIA

過去に作ったこちらの8分木を無理やり適応させて、
組み合わせ総数を減らしているのですが、
単独な3D曲線の取得する3 - C#ATIA
・・・結果が一致しない。

赤い面は総当りと8分木で同一の面を抽出できているのですが、
黄色い面は、本来抽出されるべきでない面で8分木のみで抽出されて
しまいます。

ﾃｽﾄﾃﾞｰﾀは、ちょこっと変更しただけで何度も送られてきたもの(腹が立つ)
2ﾀｲﾌﾟで行っているのですが、両方とも8分木の方が6枚余計に抽出してしまいます。

面の一致（重心・表面積）を判断する段階で余計に抽出しているのではなく
8分木を利用して比較する為の組み合わせを見つける段階で
"比較相手が無し"
として抽出してしまっている所までは突き止めたのですが、
何処をどの様に直せば良いのかな・・・。

Autodesk OnDemand Webinars

Autodeskさんは取り扱い製品数が多すぎて、迷子になってしまう為
完全に個人的な覚書です。

https://www.autodesk.co.uk/campaigns/mfg-webinar/webinars-on-demand/cad-cam

最近はほぼ使用していないPowerMillなのですが、正直な所使いこなせて
いないですし、知らない使い方が大量に有り、ﾒｰｶｰ主催のウェビナーは
非常にありがたい存在です。

リアルタイムなウェビナーに参加しても、恐らく英語な為ほぼ理解できない
ことは想定できる為、オンデマンドで一時停止・巻き戻しでｱｲｺﾝを確認しながら･･･。
ﾊﾞｰｼﾞｮﾝｱｯﾌﾟの新機能紹介動画より、遥かに実践的で助かります。

"Japan" 無いんですけど･･･

Parasolidのｲﾝﾎﾟｰﾄｴﾗｰを修復するVBS

こちらの続きです。
Parasolidのｴﾗｰ2 - C#ATIA

少しづつ時間が確保出来たので、こちらを真剣に調べてみました。
結果的に・・・　どうやらｽﾍﾟｰｽ文字だったようです。
(使用したｴﾃﾞｨﾀではｽﾍﾟｰｽ文字が上手く検索できなかったのかな･･･)

2件続いた事例を考えると、小数点直後のｽﾍﾟｰｽ文字が原因だった為
それらを削除する為のVBScriptを作成しました。

Language = "VBSCRIPT"
'*********************************
'RepairX_TFile.vbs ver 0.0.1
'不要なｽﾍﾟｰｽ文字によるｲﾝﾎﾟｰﾄｴﾗｰとなるParasolidﾌｧｲﾙを修復
'*********************************

'*** 設定 変更しないで下さい ***
Const BeforeKey = ". "
Const AfterKey = "."
'***

Call Main
wscript.Quit 0

'*********************************
Sub Main()
    'D&D
    Dim DDlist 'As Variant
    DDlist = GetDropList(wscript.Arguments)
    If Not IsArray(DDlist) Then Exit Sub

    '確認
    Dim DDlistStr 'as String

    Dim Msg 'As String
    Msg = "以下のﾌｧｲﾙをﾁｪｯｸします。よろしいですか？" + vbNewLine + _
      DDList2String(DDlist)
    If MsgBox(Msg, vbYesNo) = vbNo Then Exit Sub

    '処理
    Msg = ExecReplace(DDlist, BeforeKey, AfterKey)
    If Msg = vbNullString Then
        MsgBox "修正したﾌｧｲﾙはありませんでした"
    Else
        MsgBox Msg + "の修正したﾌｧｲﾙを作成しました"
    End If
End Sub

Private Function ExecReplace(ByVal Ary, ByVal Before, ByVal After)
    Dim i, Msg
    Msg = vbNullString
    For i = 0 To UBound(Ary)
        If IsCreateNewX_T(Ary(i), Before, After) Then
            Msg = Msg + Ary(i) + vbNewLine
        End If
    Next
    ExecReplace = Msg
End Function

Private Function IsCreateNewX_T(ByVal Path, ByVal Before, ByVal After)
    IsCreateNewX_T = False
    Dim txt
    txt = ReadFile(Path)
    If InStr(1, txt, Before) < 1 Then
        Exit Function
    End If
    
    Dim NewPath
    NewPath = GetNewName(Path)
    txt = Replace(txt, Before, After)
    Call WriteFile(NewPath, txt)
    IsCreateNewX_T = True
End Function

' *** D&D ***
'ﾄﾞﾛｯﾌﾟ処理
Private Function GetDropList(ByVal Args) 'As Variant
    Dim ArgsCount 'As Long
    ArgsCount = Args.Count
    If ArgsCount < 1 Then
        MsgBox "x_tﾌｧｲﾙ(ﾊﾟﾗｿﾘｯﾄﾞ)をD&Dして下さい"
        Exit Function
    End If

    Dim i 'As Long
    Dim X_tList() 'As Variant
    ReDim X_tList(ArgsCount)
    Dim X_tCount 'As Long
    X_tCount = -1
    Dim Path 'As Variant
    Dim ArgsPath 'As String
	
    'ContinueかGoto使いたかった･･･
    For i = 1 To ArgsCount
        ArgsPath = Args(i - 1)
        If IsExists(ArgsPath) Then
            Path = SplitPathName(ArgsPath)
            If Isx_tFile(Path(2)) Then
                X_tCount = X_tCount + 1
                X_tList(X_tCount) = JoinPathName(Path)
            End If
        End If
    Next
	
    If X_tCount < 0 Then
        Msg = "ﾁｪｯｸするx_tﾌｧｲﾙ(ﾊﾟﾗｿﾘｯﾄﾞ)がありません!"
        MsgBox Msg, vbOKOnly
        Exit Function
    End If
    ReDim Preserve X_tList(X_tCount)
    GetDropList = X_tList
End Function

'Parasolidﾁｪｯｸ　拡張子のみ
Private Function Isx_tFile(ByVal Ext) 'As Boolean
    Isx_tFile = False
    If UCase(Ext) = "X_T" Then Isx_tFile = True
End Function

'ﾘｽﾄのﾌｧｲﾙﾒｲのみ取得
Private Function DDList2String(ByVal DDlist) 'As Boolean
    Dim Ts, ToStr, i
    ToStr = ""
    For i = 0 To UBound(DDlist)
        Ts = SplitPathName(DDlist(i))
        ToStr = ToStr + Ts(1) + "." + Ts(2) + vbNewLine
    Next
    DDList2String = ToStr
End Function


' *** IO ***
'FileSystemObject
Private Function GetFSO() 'As Object
    Set GetFSO = CreateObject("Scripting.FileSystemObject")
End Function

'ﾊﾟｽ/ﾌｧｲﾙ名/拡張子 分割
'Return: 0-Path 1-BaseName 2-Extension
Private Function SplitPathName(ByVal FullPath) 'As Variant
    Dim Path(2) 'As String
    With GetFSO
        Path(0) = .getParentFolderName(FullPath)
        Path(1) = .GetBaseName(FullPath)
        Path(2) = .GetExtensionName(FullPath)
    End With
    SplitPathName = Path
End Function

'ﾊﾟｽ/ﾌｧｲﾙ名/拡張子 連結
Private Function JoinPathName(ByVal Path) 'As String
    If Not IsArray(Path) Then Stop '未対応
    If Not UBound(Path) = 2 Then Stop '未対応
    JoinPathName = Path(0) + "\" + Path(1) + "." + Path(2)
End Function

'ﾌｧｲﾙの有無
Private Function IsExists(ByVal Path) 'As Boolean
    IsExists = GetFSO.FileExists(Path)
End Function

'ﾌｧｲﾙ読み込み
Private Function ReadFile(ByVal Path) 'As Variant
    With GetFSO.GetFile(Path).OpenAsTextStream
        ReadFile = .ReadAll
        .Close
    End With
End Function

'ﾌｧｲﾙ書き込み
Private Sub WriteFile(ByVal Path, ByVal txt)
    With GetFSO.OpenTextFile(Path, 2, True)
        .Write txt
        .Close
    End With
End Sub

'重複しない名前取得
''' @param:Path-ﾌｧｲﾙﾊﾟｽ
''' @return:新たなﾌｧｲﾙﾊﾟｽ
Private Function GetNewName(ByVal OldPath)
    Dim Path
    Path = SplitPathName(OldPath)
    Path(2) = "." & Path(2)
    Dim NewPath
    NewPath = Path(0) + "\" + Path(1)
    If Not IsExists(NewPath + Path(2)) Then
        GetNewName = NewPath + Path(2)
        Exit Function
    End If
    Dim TempName, i
    i = 0
    Do
        i = i + 1
        TempName = NewPath + "_" + CStr(i) + Path(2)
        If Not IsExists(TempName) Then
            GetNewName = TempName
            Exit Function
        End If
    Loop
End Function

・複数ﾌｧｲﾙをD&Dすることが可能です。
・処理後のﾌｧｲﾙはD&Dしたファイルと同一ﾌｫﾙﾀﾞ内に、
　「元のﾌｧｲﾙ名」+「＿数字」+「.x_t」ﾌｧｲﾙが出来上がり、元のﾌｧｲﾙを上書きは
　行いません。
・過去の事例から、小数点直後に不要なｽﾍﾟｰｽ文字が入っていたため
　そのｽﾍﾟｰｽ文字を削除しているだけです。
　ｲﾝﾎﾟｰﾄｴﾗｰの全ての原因を修復する為のものでは有りません。

正直な所、客先のﾒｰﾙ環境が原因のような気がするので、他人には全く役立たない
様な気がしてます。

週末この暑さの中、ｸﾞﾗﾝﾄﾞを駆け回って疲労感たっぷりの月曜日に作っている為
不要な関数等が残っているかも････。

ﾏｸﾛを直したい(愚痴)

最近忙しい一番の原因は、週に2～3回変更が入ってくる案件。
一体何時終わるのだろう･･･。

"あぁこんな事が出来るんだなぁ" 程度に思って作ったこちらのﾏｸﾛが
活躍してくれます。

二つのﾎﾞﾃﾞｨ/形状ｾｯﾄを比較して、差分を抽出する - C#ATIA
ｻｰﾌｪｽの色をﾎﾞﾃﾞｨに反映する2 - C#ATIA

活躍してくれるのはありがたいのですが、とにかく処理が遅い。
原因はわかっているし、何をすれば速くなるかもわかっているのですが、
直している暇がありません。

社名は記載しませんが、変更箇所が33ヶ所って別部品ですよ。
ものづくり辞めちゃった会社だから、仕方ないのかな･･･。

滑らかさを手に入れる

最近忙しかったのですが、一山だけ超えました。

二番目の原因が、ﾘﾊﾞｰｽｴﾝｼﾞﾆｱﾘﾝｸﾞな仕事のﾏﾈｷﾝのﾓﾃﾞﾘﾝｸﾞです。
3Dｽｷｬﾝしたものからｻｰﾌｪｽ化したものの一部(背中)がこちら

ﾌﾘｰｽﾀｲﾙなﾗｲｾﾝｽが無い為、ｾﾞﾌﾞﾗ表示が出来ません。
代わりに　"ｻｰﾌｪｽの曲率 - 屈折領域"　で表示させると
細かなうねりが有りまくりな事がわかります。

"もっとｽｷｬﾝﾃﾞｰﾀの時点でｽﾑｰｼﾞﾝｸﾞやれよ" と言うご意見が
正しいのですが、不慣れなｿﾌﾄ・時間的な制約が有り
ﾅｶﾅｶ思うように行きません。(最終的にこの面は不採用)

折角なので、ﾌﾞﾛｸﾞのﾈﾀとして
これを何とかしてｽﾑｰｽﾞな面に出来ないか?　と挑戦してみました。
(面を重ねた状態の画像は、水色が元面　ｵﾚﾝｼﾞ色が処理後の面です)

・ﾗﾌｵﾌｾｯﾄ-ｵﾌｾｯﾄ
ﾗﾌｵﾌｾｯﾄで一度ｵﾌｾｯﾄし、同じ値を再度ｵﾌｾｯﾄして見ました。
当方ﾗｲｾﾝｽがないためﾗﾌｵﾌｾｯﾄ利用できないのですが、
こちらのｸﾞﾚｰな方法を利用しています。
ﾗｲｾﾝｽの無いｺﾏﾝﾄﾞを使用する - C#ATIA
適切な値がわからないのですが、このような設定です。

見た目の結果はこちら


細かなｼﾜｼﾜが無くなっています。
但し処理時間が結構かかるんですよね、ﾗﾌｵﾌｾｯﾄ。

・ｽｹｰﾘﾝｸﾞ
単純にｽｹｰﾘﾝｸﾞで1/1000にし、再度1000倍します。


重ねた画像を見てもわからないぐらい、ほぼ効果がありません

ここからは、履歴を捨てた方法です。

・ｽｹｰﾘﾝｸﾞ-Iges
ｽｹｰﾘﾝｸﾞで1/1000にしIgesでｴｸｽﾎﾟｰﾄ。再度ｲﾝﾎﾟｰﾄし
1000倍します。


"悪い悪い" と言われているIgesですが、再現性が良く
ほぼ効果がありません。

・ｽｹｰﾘﾝｸﾞ-model
ｽｹｰﾘﾝｸﾞで1/1000にしmodel(V4ﾌｫｰﾏｯﾄ)でｴｸｽﾎﾟｰﾄ。
再度ｲﾝﾎﾟｰﾄし1000倍します。


面が2枚に分かれてしまいましたが、ｵﾌﾟｼｮﾝの設定で
1枚で取り込むことが可能かと思います。
V4のﾄﾚﾗﾝｽの甘さを利用している為、効果をかなり感じます。

・Fusion360-ｽｹｰﾘﾝｸﾞ-Iges
Fusion360のｽｹｰﾘﾝｸﾞで1/1000し、CATIAで1000倍します。


CATIAと大差無く、ほぼ効果がありません。

・Fusion360-Tｽﾌﾟﾗｲﾝ
Fusion360にはTｽﾌﾟﾗｲﾝがあるので、単純にBrep→Tｽﾌﾟﾗｲﾝ
→Brepにしてみます。
Tｽﾌﾟﾗｲﾝ化の際の分割数は、適切な値がわからないのですが
とりあえず 20x20 で行ってみました。(最大は100っぽいです)



効果を実感します。

実は、このﾃｽﾄの最大の目的はﾃﾞｰﾀの軽さです。
以前、客先より "ﾃﾞｰﾀが重くてCAMで処理できない" と
ｸﾚｰﾑを頂いたので･･･。
軽さをどの様に比較すべきか?　がよくわかっておりませんが
全てIgesでｴｸｽﾎﾟｰﾄし、ｻｲｽﾞを比較してみます。
各ﾌｧｲﾙ名はこの様になっています。

・元のﾃﾞｰﾀ : smooth_test1-Original.igs
・ﾗﾌｵﾌｾｯﾄ-ｵﾌｾｯﾄ : smooth_test2-Rough_Offset.igs
・ｽｹｰﾘﾝｸﾞ : smooth_test3-Scaling.igs
・ｽｹｰﾘﾝｸﾞ-Iges : smooth_test4-Scaling-iges.igs
・ｽｹｰﾘﾝｸﾞ-model : smooth_test5-Scaling-model.igs
・Fusion360-ｽｹｰﾘﾝｸﾞ-Iges : smooth_test6-fusion-Scaling-iges.igs
・Fusion360-Tｽﾌﾟﾗｲﾝ : smooth_test7-fusion-Tspline.igs

結果はこちら

視覚的にもそうでしたが、”ｽｹｰﾘﾝｸﾞ-model”と ”Fusion360-Tｽﾌﾟﾗｲﾝ”が
効果を実感できます。
特にTｽﾌﾟﾗｲﾝの場合はﾌﾟﾚﾋﾞｭｰされる為、分割数を調整する事で
案外良いのかもしれません。(個人的にはmodel方式を利用しますが)
それにしてもﾗﾌｵﾌｾｯﾄのﾃﾞｰﾀの巨大さにはｶﾞｯｶﾘ･･･。

本来であれば、ある程度碁盤の目のようにﾜｲﾔｰを作成し
ﾛﾌﾄ・ﾌﾞﾚﾝﾄﾞ・ﾌｨﾙ辺りを利用して行うのが正攻法なのかも
しれないのですが、結構手間がかかるんですよね。
他にもお手軽に行える方法はあるのかな?

今回試しませんでしたが、Space-eの場合はｻｰﾌｪｽのUVの本数を
減らす事で滑らかさを手に入れることが可能だと思います。

もう一件あるんだよなぁ案件が・・・