こちらの続きです。
曲線と戦ってみる3 - C#ATIA
コードの理解を深めたかったのと、今後修正等を行いやすくしたかった為
Type1と元に作り直しました。
'vba Arc_Approximated Option Explicit Private Const mPntCount = 151& '曲線上のポイント数 Private Const mIndexMax = mPntCount - 1 '配列用のインデックス最大値 Private Const mTole = 0.02 '近似トレランス Dim mPnts As Variant '曲線上の点 Dim mPoss As Variant '曲線上の点の座標値 Dim mArcs() As Variant '近似化成功した際の3点のインデックス Dim mArcsCount& '近似化成功した数 Sub CATMain() 'Documentチェック If KCL.IsType_Of_T(CATIA.ActiveDocument, "DrawingDocument") Then MsgBox "Part又はProductファイルを開いてください" Exit Sub End If '曲線選択 Dim Msg$: Msg = "曲線を選択して下さい : ESCキー 終了" Dim SelElem As SelectedElement Set SelElem = KCL.SelectElement(Msg, Array("HybridShape")) If KCL.IsNothing(SelElem) Then Exit Sub Dim CurveRef As Reference: Set CurveRef = SelElem.Reference '各種設定 Dim Doc As PartDocument: Set Doc = KCL.GetParent_Of_T(CurveRef, "PartDocument") '点作成、座標値取得 mPnts = InitPntsOnCurve(Doc.Part, CurveRef) mPoss = GetCoordinatesAry(mPnts) '近似化 ReDim mArcs(mIndexMax) mArcsCount = 0 Call ChallengeArc(0, mIndexMax) If mArcsCount < 1 Then MsgBox "近似化できませんでした" '本当は点を削除する必要性アリ Exit Sub End If ReDim Preserve mArcs(mArcsCount - 1) '点群出力 Call AddTreePnts(mPnts, Doc.Part, "Points") '近似生成 Dim ArcCount&: ArcCount = Init3PntArc(mArcs, Doc.Part, "ConvertArcs") 'end MsgBox "円弧を" + CStr(ArcCount) + "個生成" End Sub '----- サポート関数 ----- '近似化の生成 'return-形状セット内の要素数 Private Function Init3PntArc&(ByVal Ary As Variant, ByVal Pt As Part, ByVal HBName As String) Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory Dim Ref(2) As Reference Dim Arc() As HybridShapeCircle3Points: ReDim Arc(UBound(Ary)) Dim i& On Error Resume Next For i = 0 To UBound(Ary) Set Arc(i) = Fact.AddNewCircle3Points(mPnts(Ary(i)(0)), _ mPnts(Ary(i)(1)), _ mPnts(Ary(i)(2))) Call Pt.UpdateObject(Arc(i)) If Not Err.Number = 0 Then '演算上OKでもCATIAのトレランス上NGとなるデータを除去 Set Arc(i) = Nothing Err.Clear End If Next On Error GoTo 0 Init3PntArc = AddTreePnts(Arc, Pt, HBName) End Function '形状セットに挿入 'return-形状セット内の要素数 Private Function AddTreePnts&(ByVal Ary As Variant, ByVal Pt As Part, ByVal HBName As String) Dim HB As HybridBody: Set HB = Pt.HybridBodies.Add HB.Name = HBName Dim i& For i = 0 To UBound(Ary) If Not KCL.IsNothing(Ary(i)) Then Call HB.AppendHybridShape(Ary(i)) End If Next AddTreePnts = HB.HybridShapes.Count End Function 'トレランス以内に近似化可能な3点のインデックス郡を取得 - 再帰 Private Sub ChallengeArc(ByVal StIdx&, ByVal EndIdx&) If 2 > (EndIdx - StIdx) Then Exit Sub End If Dim MidIdx&: MidIdx = Int((StIdx + EndIdx) * 0.5) Dim Arc As Variant Arc = GetCircumCircleOfTriangle(mPoss(StIdx), mPoss(MidIdx), mPoss(EndIdx)) If Not IsEmpty(Arc) Then If CheckTolerance(KCL.GetRangeAry(mPoss, StIdx + 1, EndIdx - 1), Arc) Then 'OK mArcs(mArcsCount) = Array(StIdx, MidIdx, EndIdx) mArcsCount = mArcsCount + 1 Exit Sub End If End If 'NG Call ChallengeArc(StIdx, MidIdx) Call ChallengeArc(MidIdx, EndIdx) End Sub '座標値郡が円弧のトレランス以内に有るかチェック 'GetCircumCircleOfTriangle関数の戻り値を使用すること Private Function CheckTolerance(ByVal Ary As Variant, ByVal Arc As Variant) As Boolean Dim i& For i = 0 To UBound(Ary) If mTole < Math.Abs(Arc(1) - GetDist(Ary(i), Arc(0))) Then CheckTolerance = False Exit Function End If Next CheckTolerance = True End Function '点群より座標値郡取得 Private Function GetCoordinatesAry(ByVal Pnts As Variant) As Variant Dim Poss() As Variant: ReDim Poss(mIndexMax) Dim P(2) As Variant, i& For i = 0 To mIndexMax Call Pnts(i).GetCoordinates(P) Poss(i) = P Next GetCoordinatesAry = Poss End Function '曲線上の点群作成 Private Function InitPntsOnCurve(ByVal Pt As Part, ByVal CurveRef As Reference) As Variant Dim Fact As HybridShapeFactory: Set Fact = Pt.HybridShapeFactory Dim Pnts() As Variant: ReDim Pnts(mIndexMax) Dim i&, Ratio#, Pnt As HybridShapePointOnCurve For i = 0 To mIndexMax Ratio = i / mIndexMax Set Pnts(i) = Fact.AddNewPointOnCurveFromPercent(CurveRef, Ratio, False) Call Pt.UpdateObject(Pnts(i)) Next InitPntsOnCurve = Pnts End Function '----- 演算関連 ----- '三角形の外接円の取得(3点通過円) 'return:array(0)-外心(array(2)) ' array(1)-半径 Private Function GetCircumCircleOfTriangle(ByVal P1 As Variant, _ ByVal P2 As Variant, _ ByVal P3 As Variant) As Variant Dim M1 As Variant: M1 = GetMidPnt(P1, P2) Dim M2 As Variant: M2 = GetMidPnt(P2, P3) Dim V1 As Variant: V1 = Normalize(ToVecter(P1, P2)) Dim V2 As Variant: V2 = Normalize(ToVecter(P2, P3)) Dim EulerLineVec As Variant 'V2の直交ベクトル 元n2 EulerLineVec = Normalize(Cross(V2, Cross(V1, V2))) '3点が直線上に存在している場合、除去 Dim nv#: nv = Dot(V1, EulerLineVec) If GetDistSquare(ZeroVec, EulerLineVec) < 0.001 Then Exit Function If Math.Abs(nv) < 0.001 Then Exit Function 'オリジナルは過剰な精度な為値を修正 'これが何に該当するのか不明 M2から外心までの距離? Dim t#: t = (Dot(V1, M1) - Dot(V1, M2)) / nv '外心取得 Dim Center As Variant Center = GetCircumCenter(M2, EulerLineVec, t) '半径取得 Dim Radius As Double Radius = GetDist(Center, P1) '外接円 Dim CCofT(1) As Variant CCofT(0) = Center CCofT(1) = Radius GetCircumCircleOfTriangle = CCofT End Function '2点の中間点 Private Function GetMidPnt(ByVal P1 As Variant, ByVal P2 As Variant) As Variant Dim Pnt(2) As Double, i& For i = 0 To UBound(Pnt) Pnt(i) = (P1(i) + P2(i)) * 0.5 Next GetMidPnt = Pnt End Function '外心の取得 Private Function GetCircumCenter(ByVal P As Variant, _ ByVal V As Variant, _ ByVal L As Double) As Variant Dim cc(2) As Double, i& For i = 0 To UBound(cc) cc(i) = P(i) + V(i) * L Next GetCircumCenter = cc End Function '2点間距離-平方数 Private Function GetDistSquare(ByVal P1 As Variant, ByVal P2 As Variant) As Double GetDistSquare = (P2(0) - P1(0)) * (P2(0) - P1(0)) + _ (P2(1) - P1(1)) * (P2(1) - P1(1)) + _ (P2(2) - P1(2)) * (P2(2) - P1(2)) End Function '2点間距離 Private Function GetDist(ByVal P1 As Variant, ByVal P2 As Variant) As Double GetDist = Math.Sqr(GetDistSquare(P1, P2)) End Function '----- ベクトル関連 ----- '内積3D Private Function Dot(ByVal V1 As Variant, ByVal V2 As Variant) As Double Dot = V1(0) * V2(0) + V1(1) * V2(1) + V1(2) * V2(2) End Function '外積3D Private Function Cross(ByVal V1 As Variant, ByVal V2 As Variant) As Variant Dim Vec(2) As Double Vec(0) = V1(1) * V2(2) - V1(2) * V2(1) Vec(1) = V1(2) * V2(0) - V1(0) * V2(2) Vec(2) = V1(0) * V2(1) - V1(1) * V2(0) Cross = Vec End Function '単位ベクトル化 Private Function Normalize(ByVal V1 As Variant) As Variant Dim L As Double: L = GetDist(ZeroVec, V1) If L < 0.00001 Then Normalize = ZeroVec Exit Function End If Dim Nml(2) As Double, i& For i = 0 To UBound(Nml) Nml(i) = V1(i) / L Next Normalize = Nml End Function '2点間ベクトル Private Function ToVecter(ByVal P1 As Variant, ByVal P2 As Variant) As Variant Dim Vec(2) As Double, i& For i = 0 To UBound(Vec) Vec(i) = P2(i) - P1(i) Next ToVecter = Vec End Function 'ゼロベクトル Private Function ZeroVec() As Variant ZeroVec = Array(0#, 0#, 0#) End Function
ほぼ同等な処理になっていると思いますが、相変わらずコード倍増です。
又、このコードのみでは実行できません。
同一プロジェクト内に "KCL" と言う名称の標準モジュールを
用意していただき、こちらのコードをコピペしライブラリとして
用意して頂く必要があります。
非常に個人的なCATVBA用ライブラリ - C#ATIA
念の為テスト画像を。こちらは3Dな曲線です。
マクロを実行します。
面倒だった為、出来上がった円弧の数のみをMsgBoxで表示させてます。
邪魔な点を非表示にするとこんな感じです。
「戦ってみる」とタイトルを付けたものの、他人のフンドシの説明ばかりw
ようやく戦う為の道具を手に入れた っと言う感じです。
クラス+コレクションにすべきか?、ユーザー定義型+配列にすべきか?
何時も悩む・・・