過去に作った2Dの重複線削除マクロを修正して、再度Upする意欲が
出て来たので、しばらくはこれに取り組みたいと思っています。
昔のコードに4分木を適用するのが結構面倒な事になりそうな為、
ほぼ作り直しです。
当時、重複線を判断する際、直線・円弧は何となく出来そうな
気がしていたのですが、スプラインについてはどの様に判断すれば
良いのかわかりませんでした。
結局、思いついたのは全て折れ線として変換し、直線と点同士
であれば、重複を判断出来そうだなぁと思い折れ線化の方法で
作りました。
以前の円弧→折れ線のコードを修正しテストしてみました。
選択する円弧は、3DからリンクしたものはNGです。
'vba test_Circle2Polyline using-'KCL0.09' '2D円弧の折れ線化 Option Explicit '*** 設定 *** Private Const m_PolyTol = 0.1 '折れ線化トレランス '************ Sub CATMain() 'ドキュメントのチェック If Not KCL.CanExecute("DrawingDocument") Then Exit Sub '選択 Dim Geo As Circle2D Set Geo = KCL.SelectItem("選択", "Circle2D") If KCL.IsNothing(Geo) Then Exit Sub '折れ線座標郡取得 Dim PolyList As Collection: Set PolyList = Circle2Poly(Geo) If KCL.IsNothing(PolyList) Then Exit Sub '点・線作成 Dim View As DrawingView: Set View = KCL.GetParent_Of_T(Geo, "GeometricElements") Call DumpPnt2D(PolyList, View.Factory2D) Call DumpPoly2D(PolyList, View.Factory2D) End Sub '円弧折れ線化 Private Function Circle2Poly(Geo As AnyObject) As Collection Set Circle2Poly = Nothing '円弧情報 Dim Pos(1) '始点終点パラメータ Dim StPos(1) '始点座標 Dim EnPos(1) '終点座標 Dim CnPos(1) '中心座標 Dim R# '半径 Dim Lng# '長さ With Geo Call .GetParamExtents(Pos) Call .GetPointAtParam(Pos(0), StPos) Call .GetPointAtParam(Pos(1), EnPos) Call .GetCenter(CnPos) R = .Radius Lng = .GetLengthAtParam(Pos(0), Pos(1)) End With 'トレランス内の増分パラメータ算出 Dim IncPara As Double 'パラメータ増分 Dim E_SPara As Double '終点-始点パラメータ Dim LoopCount As Integer 'カウンタ If R * 0.5 < m_PolyTol Then '小さな円弧への対応 IncPara = (Pos(1) - Pos(0)) * 0.5 Else '通常の円弧 IncPara = ArcCos(1 - m_PolyTol / R) * 2 E_SPara = Pos(1) - Pos(0) LoopCount = Fix(E_SPara / IncPara) + 1 IncPara = E_SPara / LoopCount End If '増分の三角関数 Dim SinTheta#, CosTheta# SinTheta = Sin(IncPara) CosTheta = Cos(IncPara) '折れ線化 Dim AD As Double, BD As Double '回転前の点と中心点の距離 Dim PntList As Collection: Set PntList = New Collection Dim i& Call PntList.Add(Array(StPos(0), StPos(1))) For i = 2 To LoopCount AD = PntList(i - 1)(0) - CnPos(0) BD = PntList(i - 1)(1) - CnPos(1) Call PntList.Add(Array(AD * CosTheta - BD * SinTheta + CnPos(0), _ AD * SinTheta + BD * CosTheta + CnPos(1))) Next Call PntList.Add(Array(EnPos(0), EnPos(1))) Set Circle2Poly = PntList End Function 'ArcCos Private Function ArcCos(ByVal V As Double) As Double ArcCos = Atn(-V / Sqr(-V * V + 1)) + 2 * Atn(1) End Function '確認用 '2D点 Private Sub DumpPnt2D(ByVal List As Collection, ByVal Fact As Factory2D) Dim Pos, P As Point2D For Each Pos In List Set P = Fact.CreatePoint(Pos(0), Pos(1)) P.ReportName = 3 P.Construction = False Next End Sub '2D線 Private Sub DumpPoly2D(ByVal List As Collection, ByVal Fact As Factory2D) Dim i&, L As Line2D For i = 1 To List.Count - 1 Set L = Fact.CreateLine(List(i)(0), List(i)(1), _ List(i + 1)(0), List(i + 1)(1)) Next End Sub
CATIAの機能として、曲線上に点を作成する事が可能なのですが
処理が遅い為、円弧情報から演算し指定トレランス以内で折れ線化出来る
座標値を求めています。
又、CATIAで2D円弧を書いた場合、通常は反時計回りになりますが
唯一ミラーした場合だけ時計回りとなります。
実際に試した感じです。
こんな感じの円弧ですが、閉じた円弧でも大丈夫です。
マクロ実行後は、トレランス以内となる点と直線を作ります。
拡大してみると、オレンジが元の円弧で黒がマクロで作成した点と線です。
上記のコードはトレランス0.1mmとしていたので、円弧を両側0.1mmオフセット
したものが青色です。画像は点と点の中間付近の一番トレランスから
外れやすい部分ですが、トレランス以内で折れ線化出来ています。
改めてコードを見た際、 "何でこんな計算式なのだろう?" と
思ったのですが、Sin Cosの計算回数を減らす為にこんな式にした
ようです。(本人が忘れています…)