C#ATIA

↑タイトル詐欺 主にCATIA V5 の VBA

siren v0.13 線の種類を判断する

こちらの続きです。
siren v0.13 線の種類を判断したい - C#ATIA

業務が忙しく・・・。
こんな感じのデータを作り、Igesでエクスポート。
f:id:kandennti:20170801202910p:plain
"直線" "円弧" "曲線" "点" "サーフェス" "ソリッド" が
混在しています。 このIgesから境界線等ではない
純粋な線の要素を抜き出します。

又、抜き出した線の種類を標準出力に表示します。

#Siren_script Export_Curve_Test
include Siren

fName = "/curves"
$inPath = ARGV[0] + fName + ".igs"
$exPath = ARGV[0] + fName + "-res.igs"

def Pause()
	print "押して!"
	str = gets
end

def GetEdgeType(shp)
	return unless shp.edge?
	begin
		return "curve" unless shp.nurbs_def.size < 1
	rescue
	end
	
	begin
		return "line" if shp.to_pts.size < 3
	rescue
	end
	
	return "circle"
end

###########
comp = Siren.load_model $inPath
p "total_edges : " + comp.edges().size.to_s

edgelst = comp.to_a.select { |x|
	x.edge? == true
}

edgelst = edgelst + comp.to_a.select { |x|
	x.wire? == true
}.edges.flatten

p "**************"
edgelst.each{|x|
	print x.to_s + "" +  GetEdgeType(x) + " です\n"
}

cmp = edgelst.to_comp

begin
	Siren.save_model cmp , $exPath
rescue
	p "export errer!"
end
 
###########
puts "done."
Pause()

悩んだ挙句、GetEdgeType関数を作り、各メソッドが成功するか?どうか?
で線のタイプを判断する と言うかなりベタな方法しか思い付かない
上に、Rubyっぽさの微塵も感じないコードになりました。
(本来なら、もっと素敵なコードで実現できるはず・・・)

実行結果はこちらで、出来上がったIgesをインポートすると
f:id:kandennti:20170801202921p:plain
判断も出来てます。
本当は ".edge_type" みたいにしたいんだけどなぁ。

siren v0.13 線の種類を判断したい

こちらの続きです。
siren v0.13 NURBS曲線・Bスプライン曲線 - C#ATIA

通過点を指定するスプラインを試したところ出来たので、
NURBS曲線・Bスプライン曲線はちょっと諦める事にしました。

次に線が "直線" "円弧" "曲線" を判断出来るようにしたい
所なんです。

こんなデータをIgesで吐き出し
f:id:kandennti:20170727182716p:plain
それを試しに読み込んで調べてみました。
試していくうちに、直線・円弧・曲線・面・点となってしまい
変数名等がおかしいですが・・・

#
include Siren

fName = "/curves"
$inPath = ARGV[0] + fName + ".igs"
$exPath = ARGV[0] + fName + "-res.igs"
$dpPath = ARGV[0] + fName + "_dump.txt"

def wDump(i)
  if i.kind_of?(String)
     open($dpPath, "a") {|f| f.write "\r\n" + i}
  end
end

def Pause()
  print "押して!"
  str = gets
end

open($dpPath, "w") {|f| f.write "start"}
###########
crvs = Siren.load_model $inPath
p "total : " + crvs.subshapes.size.to_s
shps = crvs.to_a

begin
 shps.each{|shp|
  p "***"
  p "to_s : " + shp.to_s	
  p "shapetype : " + shp.shapetype.to_s
  #p shp.shapetype.to_sname -ng
  #p shp.curvetype -ng
  #p shp.geomtype -ng
  #p shp.siren_curve_type -ng
 }
rescue
 p $@
end
###########
wDump("end")
puts "done."
Pause()

読み込んだIgesをバラシ、ループさせて1個づつ調べているのですが
f:id:kandennti:20170727182736p:plain
やっと見つけたshapetypeで、線の種類を判断できると思ったの
ですが、直線・円弧・曲線 全て "6" が返って来ており
判断できません・・・。(恐らくSiren::Edgeが返って来ているのでしょう)

こちらにあったテストコードの最後の方に
mruby-siren/mruby-siren.rb at ae31b439725ec39b5c998239a547f0ca15ce6385 · dyama/mruby-siren · GitHub
".shapetype.to_sname" を見つけたのですが、エラーになります。
(コード的にv0.13のものでは無いので・・・)

他にも "curvetype" "geomtype" "siren_curve_type" 等、それっぽい
ものも試したのですが全てダメでした。

ん~諦めようかな・・・。

siren v0.13 NURBS曲線・Bスプライン曲線

こちらの続きです。

行き詰まり感たっぷりなのですが、ちょっと試してみたい事が
あったので引き続き挑戦。

こちらの何でもない3Dな曲線をCATIAで作成しIgesでエクスポート。(curve1.igs)
f:id:kandennti:20170727152855p:plain
続いてSirenスプリクトをこんな感じで作成します。

#
include Siren

fName = "/curve1"
$inPath = ARGV[0] + fName + ".igs"
$exPath = ARGV[0] + fName + "-res.igs"
$dpPath = ARGV[0] + fName + "_dump.txt"

def wDump(i)
  if i.kind_of?(String)
     open($dpPath, "a") {|f| f.write "\r\n" + i}
  end
end

wDump("start")
###########

shp = Siren.load_model $inPath
wDump(shp.to_s)
wDump(shp.nurbs_def.to_s)
Siren.save_model shp, $exPath

###########
wDump("end")
puts "done."

何をしているかと言いますと、CATIAで作成したIgesを
Sirenで読み込み、再度別名のIgesでエクスポートしているだけです。
但し、途中で読み込んだ曲線の次数やノットベクトル等の情報を
ダンプさせています。

ダンプさせた内容がこちら

start

#<Shape:0x27577e8 @type=EDGE>

[5, 

[0, 17.39738523, 28.8962564, 39.23864718, 50.07377854, 67.53908293], 

[6, 3, 3, 3, 3, 6], 

[#<Vec:0x27573a5 @x=10.000000, @y=-20.000000, @z=-10.000000>,
 #<Vec:0x2757395 @x=9.587310, @y=-19.663785, @z=-7.111170>,
 #<Vec:0x2757345 @x=9.066687, @y=-19.247257, @z=-4.318377>,
 #<Vec:0x2757335 @x=8.414916, @y=-18.739432, @z=-1.647258>,
 #<Vec:0x27572e5 @x=7.064933, @y=-17.728351, @z=2.468286>,
 #<Vec:0x27572d5 @x=5.183948, @y=-16.463305, @z=5.802195>,
 #<Vec:0x2757285 @x=4.342483, @y=-15.922227, @z=6.978457>,
 #<Vec:0x2757275 @x=2.558949, @y=-14.842477, @z=8.853440>,
 #<Vec:0x2757225 @x=0.445590, @y=-13.724272, @z=9.964573>,
 #<Vec:0x2757215 @x=-0.623246, @y=-13.198986, @z=10.301741>,
 #<Vec:0x27571c5 @x=-2.929444, @y=-12.162037, @z=10.599622>,
 #<Vec:0x27571b5 @x=-5.413111, @y=-11.251836, @z=10.141983>,
 #<Vec:0x2757165 @x=-6.714933, @y=-10.831739, @z=9.723114>,
 #<Vec:0x2757155 @x=-10.156001, @y=-9.869701, @z=8.217441>,
 #<Vec:0x2757105 @x=-13.650081, @y=-9.267638, @z=5.788367>,
 #<Vec:0x27570f5 @x=-15.795199, @y=-9.037527, @z=4.030341>,
 #<Vec:0x27570a5 @x=-17.911583, @y=-8.933958, @z=2.088417>,
 #<Vec:0x2757095 @x=-20.000000, @y=-8.944927, @z=0.000000>],

[1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1],

0, 

67.53908293]

end

恐らく、(僕を含めて)何の事だか判らないだろうと思います。

開発者の方のこちらを参考に見てみると
OpenCASCADE で NURBS 曲線を作成する – dyama's page
ん~ 引数multsの説明がされていました。

ダンプさせた際の
[0, 17.39738523,・・・
が、multsに該当するのかと思ったのですが、説明書きとは違います。
OpenCascadeと引数の順番が違うのも、ちょっと気になるのですが・・・。

イロイロやっているのですが、上手く行かないなぁ。

siren v0.13 再び挑戦してみる2

こちらの続きです。
siren v0.13 再び挑戦してみる - C#ATIA

既に諦めかかってます。 欲しかったのは3Dな曲線で
NURBS曲線・Bスプライン曲線辺りです。

GitHubの "シェイプ生成メソッド" を参考に テストされたスプリクトコードを
試しているのですが、上手く出来ないです・・・。

include Siren

degree = 2
knots = [0.0, 1.0, 2.0]
mults = [3, 1, 3]
poles = [[10, 0, 7], [7, 0, 7], [3, 0, 8], [0, 0, 7]]
weights = [1.0, 1.2, 1.0, 1.0]

bs = Siren.curve[bscurve.new[degree, knots, mults, poles, weights], 0.1, 1.2]
Siren.save_model bs, ARGV[0] + "/bs.igs"

puts "done."

数値的にはUpされていたテストコードのまま(と言いますか、ほぼそのまま)
ダメなんです。 デバッグの方法がわからないので、ちょっと変えては実行しか
方法がわからないんです。 ん~ 一日で諦めちゃおうかな・・・。

siren v0.13 再び挑戦してみる

昨日ちょっと良い事を思いついたので、1年半ぶりぐらいにsiren
再挑戦する事にしました。

以前利用させてもらった時は "v0.11" だったのですが、
最新版は "v0.13" です。

こちらで作ったsirenスプリクト実行用vbsを参照先パスだけ
変更したのですが、ダメでした。
Sirenテスト-polygon - C#ATIA

sirenの実行ファイル名やファイル位置等がv0.12 → v0.13で
大きく変更されたりしたようです。
ついでにD&Dで実行するように修正してみました。

'vbs SirenTestStart013.vbs
'D&DによるSirenスプリクト実行  Siren v0.13用
Language = "VBSCRIPT"

'*** setting ***
'mruby.exe(Siren)ファイルのフルパス
SirenPath="C:\siren\siren_0.13_mingw32\bin\mruby.exe"
'******

Main()
WScript.Quit 0

Sub Main()
    If wscript.Arguments.Count < 1 Then
        MsgBox "SirenスプリクトファイルをD&Dして下さい"
        Exit Sub
    End If	
    Dim Args : Args = wscript.Arguments(0)
    Dim fso : set fso = createObject("Scripting.FileSystemObject")
    Dim ScriptPath : ScriptPath = Replace(fso.getParentFolderName(Args), "\", "/")
    Dim ScriptName : ScriptName = fso.GetFileName(Args)
    Dim WshShell : Set WshShell = CreateObject("WScript.Shell")
    Call WshShell.Run(SirenPath + " " + ScriptPath + "/" + ScriptName + " " + ScriptPath, 1, False)
End Sub

D&Dは1ファイルだけにしています。(他にもイマイチな部分多数)

こちらのサンプルをお借りし、エクスポートフォーマットを変更したりし
テストしてみました。
mruby-siren/tree.rb at master · dyama/mruby-siren · GitHub

#!/usr/bin/siren
# coding: utf-8
#
# fractal tree 
#
include Siren
expFileName = ARGV[0] + "/tree"

$start_len = 100.0

def tree(cur_pt, dir, len)
  nxt_pt = cur_pt + dir * len
  edges = [ line(cur_pt, nxt_pt) ]
  len *= 0.75
  if len > $start_len / 10.0
    edges.concat tree(nxt_pt, dir.rotate(Vec.ydir, 30.0.to_rad), len)
    edges.concat tree(nxt_pt, dir.rotate(Vec.ydir, -30.0.to_rad), len)
  end
  return edges
end

lines = tree([0, 0, 0].to_v, Vec.zdir, $start_len)

comp = lines.to_comp
Siren.save_iges comp, expFileName + ".igs"
Siren.save_step comp, expFileName + ".stp"

puts "done."

スプリクトの書式も少し変更されたような・・・。
Stepフォーマットのエクスポートがサポートされてるんですよ。
f:id:kandennti:20170726154324p:plain
無事出来ました。
StepファイルがIgesファイルの10倍ぐらいのサイズなんですが、
こんなもんなんですかね?

3Dの点をリンク付きでスケッチ投影

COEでこちらの記述を見て、作ってみました。
http://www.coe.org/p/fo/st/thread=29815

レスしたものはインデントが消えてしまっているので

Sub CATMain()
    'HybridBody-Points
    Dim HBdy As HybridBody
    Set HBdy = SelectItem("Select a HybridBody : ESC = Cancel", Array("HybridBody"))
    If HBdy Is Nothing Then Exit Sub
    
    'Part
    Dim Pt As Part: Set Pt = GetParent_Of_T(HBdy, "Part")
    If Pt Is Nothing Then Exit Sub
    
    'Point Refs
    Dim PntRefLst As Collection: Set PntRefLst = GetPntRefs(HBdy, Pt)
    If PntRefLst Is Nothing Then Exit Sub
    
    'Sketch_Support
    Dim Pln As Plane
    Set Pln = SelectItem("Select a Sketch_Support_Plane : ESC = Cancel", Array("Plane"))
    If Pln Is Nothing Then Exit Sub
    
    'Part Check
    Dim TmpPt As Part: Set TmpPt = GetParent_Of_T(Pln, "Part")
    If Not (Pt Is TmpPt) Then
        MsgBox "Please choose the Plane of the same Part!"
        Exit Sub
    End If
    
    'HybridBody_Sketch
    Dim NewHbdy As HybridBody: Set NewHbdy = Pt.HybridBodies.Add()
    Dim Skt As Sketch: Set Skt = InitSketch(NewHbdy, Pt.CreateReferenceFromObject(Pln))
    
    'Projection
    Call ProjectionPnts(Skt, PntRefLst)
    Pt.UpdateObject Skt
    
    MsgBox "Done"
End Sub

'点投影
Private Sub ProjectionPnts(ByVal Skt As Sketch, ByVal PntRefLst As Collection)
    Dim Fact2D As Factory2D
    Dim Ref As Reference
    Dim Geos As GeometricElements
    
    On Error Resume Next
        Set Fact2D = Skt.OpenEdition()
        For Each Ref In PntRefLst
            Set Geos = Fact2D.CreateProjections(Ref)
            Geos.Item(1).Name = Ref.DisplayName
        Next
        Skt.CloseEdition
    On Error GoTo 0
End Sub

'スケッチ生成
Private Function InitSketch(ByVal HBdy As HybridBody, ByVal SktSptRef As Reference) As Sketch
    Set InitSketch = HBdy.HybridSketches.Add(SktSptRef)
End Function

'点リファレンス取得
Private Function GetPntRefs(ByVal HBdy As HybridBody, ByVal Pt As Part) As Collection
    Set GetPntRefs = Nothing
    
    Dim HShps As HybridShapes: Set HShps = HBdy.HybridShapes
    If HShps.Count < 1 Then Exit Function
    
    Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory
    
    Dim PntRefLst As Collection: Set PntRefLst = New Collection
    Dim HShp As HybridShape
    For Each HShp In HShps
        If Fact.GetGeometricalFeatureType(HShp) = 1 Then
            PntRefLst.Add Pt.CreateReferenceFromObject(HShp)
        End If
    Next
    If PntRefLst.Count < 1 Then Exit Function
    
    Set GetPntRefs = PntRefLst
End Function


'選択
''' @param:Msg-メッセージ
''' @param:Filter-array(string),string 選択フィルター(指定無し時AnyObject)
''' @return:AnyObject
Private Function SelectItem(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As AnyObject
    Dim SE As SelectedElement
    Set SE = SelectElement(Msg, Filter)
    
    If IsNothing(SE) Then
        Set SelectItem = SE
    Else
        Set SelectItem = SE.Value
    End If
End Function

'選択
''' @param:Msg-メッセージ
''' @param:Filter-array(string),string 選択フィルター(指定無し時AnyObject)
''' @return:SelectedElement
Private Function SelectElement(ByVal Msg$, _
                           Optional ByVal Filter As Variant = Empty) _
                           As SelectedElement
    Dim Sel As Variant: Set Sel = CATIA.ActiveDocument.Selection
    Sel.Clear
    Select Case Sel.SelectElement2(Filter, Msg, False)
        Case "Cancel", "Undo", "Redo"
            Exit Function
    End Select
    Set SelectElement = Sel.Item(1)
    Sel.Clear
End Function

'T型のParent取得 Nameでのチェックも必要
''' @param:AOj-AnyObject
''' @param:T-String
''' @return:AnyObject
Private Function GetParent_Of_T(ByVal AOj As AnyObject, ByVal t$) As AnyObject
    If TypeName(AOj) = TypeName(AOj.Parent) And _
       AOj.Name = AOj.Parent.Name Then
        Set GetParent_Of_T = Nothing
        Exit Function
    End If
    If TypeName(AOj) = t Then
        Set GetParent_Of_T = AOj
    Else
        Set GetParent_Of_T = GetParent_Of_T(AOj.Parent, t)
    End If
End Function

作ったものは、スケッチから全て作ってしまうマクロなんですが、
質問者の望んでいるものは、手動でスケッチに投影したものの
リンク元の名前に取得したい ってことだろうと
レスした後に気が付きました・・・。

二つのボディ/形状セットを比較して、差分を抽出する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分木の効果は出ていますが、もう少し効果が出るかと
期待していたのですが・・・。