nanoCAD 5.0 VB.NET サンプル 2024/12/04, 10
やっていることは、LISP と同じで LISP より少し(1.5倍くらい）速いです。
電気回路図用のシンボルでは、体感的な差は感じられないので、.NET 化する意味はあまり無いように思います。
LISP からコマンドを使う場合は、図形選択時に、"H" オプションを使って、ハンドル (cdr (assoc 5 ent))
を送ると、そのまま使えます。
nanoCAD 5.0 では、.NET で作成した LISP 関数は認識されないっぽいです。
■選択したブロックの見えている図形の矩形範囲を取得
・2024/12/10 ReDim の間違いを修正
■選択したブロックの見えている図形に交差する LINE をカット
※ .NET での GetKeywords の使い方がよく分かっていません・・・。
※ GetPointで、直交モードがオンのとき、X または Y が 0 になる現象があります。
Imports Teigha.Runtime
Imports HostMgd.ApplicationServices
Imports Teigha.DatabaseServices
Imports Teigha.Geometry
Imports HostMgd.EditorInput
' alias
Imports _AcRx = Teigha.Runtime
Imports _AcAp = HostMgd.ApplicationServices
Imports _AcDb = Teigha.DatabaseServices
Imports _AcGe = Teigha.Geometry
Imports _AcEd = HostMgd.EditorInput
Imports _AcGi = Teigha.GraphicsInterface
Imports _AcClr = Teigha.Colors
Imports _AcWnd = HostMgd.Windows
Public Class Class1
'' ブロックの見えている矩形範囲と内部図形を返す
Public Function getBlockRect(blkObjId As ObjectId, ByRef minx As Double, ByRef miny As Double, ByRef maxx As Double, ByRef maxy As Double) As DBObjectCollection
Dim doc As _AcAp.Document = _AcAp.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Dim result As DBObjectCollection = Nothing
Using tr As Transaction = db.TransactionManager.StartTransaction
Try
'' フリーズ、非表示でない画層名を取得しておく
Dim layNames() As String
ReDim layNames(0) '' 配列数を 0 に
'' 画層テーブルを取得
Using lt As LayerTable = tr.GetObject(db.LayerTableId, OpenMode.ForRead)
Dim ltr As LayerTableRecord
Dim idx As Integer = 0
For Each objid In lt
ltr = tr.GetObject(objid, OpenMode.ForRead)
If Not (ltr.IsHidden Or ltr.IsFrozen) Then ''ltr.IsLocked Or ''ロック画層は含めない時
ReDim Preserve layNames(idx) '' 2024/12/10 間違いを修正（添字の上限に変更）
layNames(idx) = ltr.Name
idx = idx + 1
End If
Next
End Using
ed.WriteMessage(vbLf + blkObjId.ToString)
Dim ent As Entity = tr.GetObject(blkObjId, OpenMode.ForRead)
If TypeOf ent Is BlockReference Then
Dim blkref = TryCast(ent, BlockReference)
''ed.WriteMessage(vbLf + blkref.Name) ''ブロック名
''Dim blkPos As Point3d = blkref.Position '' ブロックの挿入基点（未使用）
Dim objs = New DBObjectCollection
blkref.Explode(objs) '' 分解
''ed.WriteMessage(vbLf + "Explode count=" + objs.Count.ToString)
Dim bound As Extents3d
Dim count As Integer = 0
result = New DBObjectCollection
For Each obj In objs
Dim et As Entity = TryCast(obj, Entity)
''Dim etName As String = et.GetType().Name
''ed.WriteMessage(vbLf + etName) '' 図形の名前
If Array.IndexOf(layNames, et.Layer) >= 0 Then ''見えている図形が対象
If etName = "Circle" Or etName = "Line" Or etName = "Arc" Or etName = "Polyline" Then
result.Add(obj)
bound = et.Bounds
If count = 0 Then
minx = bound.MinPoint.X
miny = bound.MinPoint.Y
maxx = bound.MaxPoint.X
maxy = bound.MaxPoint.Y
Else '' 2024/12/10 Math.Min, Math.Max に変更
minx = Math.Min(minx, bound.MinPoint.X)
miny = Math.Min(miny, bound.MinPoint.Y)
maxx = Math.Max(maxx, bound.MaxPoint.X)
maxy = Math.Max(maxy, bound.MaxPoint.Y)
End If
count = count + 1
End If
End If
Next
End If
Catch ex As System.Exception
_AcAp.Application.ShowAlertDialog(ex.Message)
End Try
End Using
Return result
End Function
'' 点列のうち、相互距離が最大な２点を得る
Sub maxDistPts(pts As Point3dCollection, ByRef p1 As Point3d, ByRef p2 As Point3d)
Dim maxDist = 0.0
Dim dist As Double
Dim cnt As Integer = pts.Count
If cnt = 2 Then
p1 = pts(0)
p2 = pts(1)
Else
For i = 0 To cnt - 2
For j = i + 1 To cnt - 1
dist = pts(i).DistanceTo(pts(j))
If dist > maxDist Then
maxDist = dist
p1 = pts(i)
p2 = pts(j)
End If
Next
Next
End If
End Sub
'' 点列のうち、相互距離が最大な２点を得る（未使用）
Public Shared Sub maxDist4p(p1 As Point3d, p2 As Point3d, p3 As Point3d, p4 As Point3d, ByRef resp1 As Point3d, ByRef resp2 As Point3d)
Dim pts As Point3dCollection = New Point3dCollection
pts.Add(p1)
pts.Add(p2)
pts.Add(p3)
pts.Add(p4)
maxDistPts(pts, resp1, resp2)
End Sub
'' 点が線分上にあるか
Public Shared Function pointOnLine(pt As Point3d, p1 As Point3d, p2 As Point3d) As Boolean
Dim lineSeg As LineSegment3d = New LineSegment3d(p1, p2)
Return lineSeg.IsOn(pt)
End Function
'' ブロックに交差する LINE をカット
<CommandMethod("netbtrim")>
Public Sub netbtrim()
Dim doc As _AcAp.Document = _AcAp.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Dim fuzz As Double = 0.1 '' 矩形範囲の少し外側にかかる線分を選択する
Using tr As Transaction = db.TransactionManager.StartTransaction
Try
Dim res As PromptEntityResult = ed.GetEntity(vbLf + "交差線分をカットするブロックを指示 : ")
If (res.Status = PromptStatus.OK) Then
Dim ent As Entity = tr.GetObject(res.ObjectId, OpenMode.ForRead)
If TypeOf ent Is BlockReference Then
Dim blkref As BlockReference = TryCast(ent, BlockReference)
''Dim blkPos As Point3d = blkref.Position '' ブロックの挿入基点（未使用）
Dim minx, miny, maxx, maxy As Double
'' 見えているブロック内部の図形と矩形範囲
Dim blkObjs As DBObjectCollection = getBlockRect(res.ObjectId, minx, miny, maxx, maxy)
If blkObjs.Count > 0 Then
Dim pt1 As Point3d = New Point3d(minx - fuzz, miny - fuzz, 0.0)
Dim pt2 As Point3d = New Point3d(maxx + fuzz, maxy + fuzz, 0.0)
Dim filter As TypedValue() = {New TypedValue(DxfCode.Start, "LINE")}
'' 交差線分をセレクト
Dim pres As PromptSelectionResult = ed.SelectCrossingWindow(pt1, pt2, New SelectionFilter(filter))
Dim count As Integer = 0
Dim objIdArray() As ObjectId = pres.Value.GetObjectIds()
''ed.WriteMessage(vbLf + "lines=" + objIdArray.Count.ToString)
Dim acBlkTbl As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim model As BlockTableRecord = tr.GetObject(acBlkTbl(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
For Each objId As ObjectId In objIdArray ''線分ごとに
Dim intpts As Point3dCollection = New Point3dCollection '' 線分ごとの交点
Dim lnobj As Line = TryCast(tr.GetObject(objId, OpenMode.ForWrite), Line)
For Each blkobj In blkObjs
Dim pts As Point3dCollection = New Point3dCollection
'' ブロック内部図形との交点
lnobj.IntersectWith(blkobj, Intersect.OnBothOperands, pts, IntPtr.Zero, IntPtr.Zero)
'' 同一直線上の点を含める
If TypeOf blkobj Line Then
Dim blkln As Line = TryCast(blkobj, Line)
If pointOnLine(blkln.StartPoint, lnobj.StartPoint, lnobj.EndPoint) Then
pts.Add(blkln.StartPoint)
End If
If pointOnLine(blkln.EndPoint, lnobj.StartPoint, lnobj.EndPoint) Then
pts.Add(blkln.EndPoint)
End If
End If
If pts IsNot Nothing Then
Dim i As Integer
For i = 0 To pts.Count - 1
intpts.Add(pts(i)) '' 線分ごとの交点リストに追加
Next
End If
Next
'' 線分ごとの交点を整理
'' 先に端点を intpts に含めておく
'' 始点、終点がどちらも矩形内にある場合を想定していない
Dim mode As Integer = 0
If (lnobj.StartPoint.X >= minx) And (lnobj.StartPoint.X <= maxx) And (lnobj.StartPoint.Y >= miny) And (lnobj.StartPoint.Y <= maxy) Then
intpts.Add(lnobj.StartPoint)
mode = 1
ElseIf (lnobj.EndPoint.X >= minx) And (lnobj.EndPoint.X <= maxx) And (lnobj.EndPoint.Y >= miny) And (lnobj.EndPoint.Y <= maxy) Then
intpts.Add(lnobj.EndPoint）
mode = 2
End If
If intpts.Count >= 2 Then
''相互距離が最大の2点を得る
Dim p1 As Point3d = New Point3d(0, 0, 0)
Dim p2 As Point3d = New Point3d(0, 0, 0)
maxDistPts(intpts, p1, p2)
'' 確認の為に円を作成
'Dim cir As Circle = New Circle
'cir.Center = p1
'cir.Radius = 0.1
'model.AppendEntity(cir)
'tr.AddNewlyCreatedDBObject(cir, True)
'Dim cir2 As Circle = New Circle
'cir2.Center = p2
'cir2.Radius = 0.1
'model.AppendEntity(cir2)
'tr.AddNewlyCreatedDBObject(cir2, True)
If mode = 1 Then ''始点が矩形内
lnobj.StartPoint = p1
ElseIf mode = 2 Then
lnobj.EndPoint = p1
Else
Dim lnobj2 As Line = New Line
lnobj2.CopyFrom(lnobj)
If lnobj.StartPoint.DistanceTo(p1) < lnobj.StartPoint.DistanceTo(p2) Then
lnobj.EndPoint = p1
lnobj2.StartPoint = p2
Else
lnobj.EndPoint = p2
lnobj2.StartPoint = p1
End If
model.AppendEntity(lnobj2)
End If
End If
Next
'' Save the new object to the database
tr.Commit()
End If
End If
End If
Catch ex As System.Exception
_AcAp.Application.ShowAlertDialog(ex.Message)
End Try
End Using
End Sub
'' ブロックを囲う矩形範囲を取得（見えている図形の範囲）
<CommandMethod("netbrect")>
Public Sub netbrect()
Dim doc As _AcAp.Document = _AcAp.Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Dim ed As Editor = doc.Editor
Using tr As Transaction = db.TransactionManager.StartTransaction
Try
Dim res = ed.GetEntity(vbLf + "矩形範囲を取得するブロックを指示 : ")
If (res.Status = PromptStatus.OK) Then
Dim minx, miny, maxx, maxy As Double
If getBlockRect(res.ObjectId, minx, miny, maxx, maxy) IsNot Nothing Then
'' LISP から使うために、結果をシステム変数で渡す
_AcAp.Application.SetSystemVariable("userr1", minx)
_AcAp.Application.SetSystemVariable("userr2", miny)
_AcAp.Application.SetSystemVariable("userr3", maxx)
_AcAp.Application.SetSystemVariable("userr4", maxy)
'' 確認の為に描画
Dim pso As New PromptSelectionOptions
pso.Keywords.Add("Yes(Y)")
pso.Keywords.Add("No(N)")
pso.MessageForAdding = vbLf & " 矩形範囲を描画しますか？ : " & vbLf & pso.Keywords.GetDisplayString(True)
pso.SelectEverythingInAperture = True
Dim psr As PromptSelectionResult = Nothing
psr = ed.GetSelection(pso)
If psr.StringResult = "Yes(Y)" Then
Dim pts(4) As Point2d
pts(0) = New Point2d(minx, miny)
pts(1) = New Point2d(maxx, miny)
pts(2) = New Point2d(maxx, maxy)
pts(3) = New Point2d(minx, maxy)
Dim pline As New Polyline()
Dim i As Integer
For i = 0 To 3
pline.AddVertexAt(i, pts(i), 0.0, 0.0, 0.0)
Next
pline.Closed = True
' Open the Block table for read
Dim acBlkTbl As BlockTable = tr.GetObject(db.BlockTableId, OpenMode.ForRead)
' Open the Block table record Model space for write
Dim model As BlockTableRecord = tr.GetObject(acBlkTbl(BlockTableRecord.ModelSpace), OpenMode.ForWrite)
' Add the new object to the block table record and the transaction
model.AppendEntity(pline)
tr.AddNewlyCreatedDBObject(pline, True)
' Save the new object to the database
tr.Commit()
End If
End If
End If
Catch ex As System.Exception
_AcAp.Application.ShowAlertDialog(ex.Message)
End Try
End Using
End Sub
End Class