こちらの続きです。
http://kantoku.hatenablog.com/entry/2016/11/24/173743
http://kantoku.hatenablog.com/entry/2017/07/19/190425
原因を突き止め切れていないのですが、結果が総当りと
一致するようになりました。
まずは、本マクロのエントリーポイントを持つ標準モジュール "GetChangeArea.bas"
です。
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
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
Private Function GetCombinationAry(ByVal Ary1 As Variant, ByVal Ary2 As Variant) As Variant
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
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
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
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 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
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
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
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" です。
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&()
Function GetLinerOctreeList(ByVal Pnts As Collection, ByVal Tolerance#, ByVal MAXCOUNT&)
Set GetLinerOctreeList = Nothing
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
Dim CheckList As Collection: Set CheckList = New Collection
Call CheckList.Add(PntIdxList)
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
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
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
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
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
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
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
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
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
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
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
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
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分木の効果は出ていますが、もう少し効果が出るかと
期待していたのですが・・・。