Hello!
I want to create an outermost border for curves in a selection, some work well and some polylines don't. I've tried everything but can't fix it, hope you can help me fix it
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.BoundaryRepresentation
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Imports CadDb = Autodesk.AutoCAD.DatabaseServices
Public Module M_Boundary
Public Class OutLiner
Private _dwg As Document
Public Sub New(dwg As Document)
_dwg = dwg
End Sub
Public Sub DrawOutline(entIds As IEnumerable(Of ObjectId))
Using polyline = GetOutline(entIds)
Using tran = _dwg.TransactionManager.StartTransaction()
Dim space = DirectCast(tran.GetObject(_dwg.Database.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
space.AppendEntity(TryCast(polyline, Entity))
tran.AddNewlyCreatedDBObject(TryCast(polyline, Entity), True)
tran.Commit()
End Using
End Using
End Sub
Public Function GetOutline(entIds As IEnumerable(Of ObjectId)) As Entity
Dim regions = New List(Of Region)()
Using tran = _dwg.TransactionManager.StartTransaction()
For Each entId In entIds
Dim entity = TryCast(tran.GetObject(entId, OpenMode.ForRead), Entity)
If entity IsNot Nothing Then
Dim entityRegion As List(Of Region) = Nothing
Select Case entity.GetType()
Case GetType(Polyline)
entityRegion = GetRegionFromPolyline(TryCast(entity, Polyline))
Case GetType(Circle)
entityRegion = GetRegionFromCircle(TryCast(entity, Circle))
Case GetType(Arc)
entityRegion = GetRegionFromArc(TryCast(entity, Arc))
Case GetType(Ellipse)
entityRegion = GetRegionFromEllipse(TryCast(entity, Ellipse))
Case GetType(Line)
entityRegion = GetRegionFromLine(TryCast(entity, Line))
Case Else
' Unsupported type
Continue For
End Select
If entityRegion IsNot Nothing Then
regions.AddRange(entityRegion)
End If
End If
Next
tran.Commit()
End Using
Using region = MergeRegions(regions)
If region IsNot Nothing Then
Dim brep = New Brep(region)
Dim points = New List(Of Point2d)()
Dim faceCount = brep.Faces.Count()
Dim face = brep.Faces.First()
For Each iloop In face.Loops
If iloop.LoopType = LoopType.LoopExterior Then
For Each vertex In iloop.Vertices
points.Add(New Point2d(vertex.Point.X, vertex.Point.Y))
Next
Exit For
End If
Next
Return CreatePolyline(points)
Else
Return Nothing
End If
End Using
End Function
'Private Function GetRegionFromPolyline(poly As CadDb.Polyline) As List(Of Region)
' Return GetRegionFromCurve(poly)
'End Function
Private Function GetRegionFromPolyline(poly As CadDb.Polyline) As List(Of Region)
Dim regions = New List(Of Region)()
Dim sourceCol = New DBObjectCollection()
' Create a list of all points in the polyline
Dim points = New List(Of Point3d)()
For i = 0 To poly.NumberOfVertices - 1
points.Add(poly.GetPoint3dAt(i))
Next
' Calculate the centroid of points
Dim centroid = New Point3d(points.Average(Function(p) p.X), points.Average(Function(p) p.Y), points.Average(Function(p) p.Z))
' Sort points by angle
points.Sort(Function(p1, p2) Math.Atan2(p1.Y - centroid.Y, p1.X - centroid.X).CompareTo(Math.Atan2(p2.Y - centroid.Y, p2.X - centroid.X)))
' Create a new closed polyline from the sorted points
Dim sortedPoly = New CadDb.Polyline()
For i As Integer = 0 To points.Count - 1
sortedPoly.AddVertexAt(i, New Point2d(points(i).X, points(i).Y), 0, 0, 0)
Next
sortedPoly.Closed = True
' Add the polyline to the source collection
sourceCol.Add(sortedPoly)
' Create regions from the source collection
Dim dbObjs = Region.CreateFromCurves(sourceCol)
For Each obj In dbObjs
If TypeOf obj Is Region Then regions.Add(TryCast(obj, Region))
Next
Return regions
End Function
Public Function GetRegionFromCircle(circle As CadDb.Circle) As List(Of Region)
Dim regions = New List(Of Region)()
Dim sourceCol = New DBObjectCollection()
Dim dbObj = New CadDb.Polyline()
Dim numPoints As Integer = 100 ' increase this for higher precision
For i = 0 To numPoints
Dim param = 2 * Math.PI * i / numPoints
Dim point = New Point2d(circle.Center.X + circle.Radius * Math.Cos(param), circle.Center.Y + circle.Radius * Math.Sin(param))
dbObj.AddVertexAt(i, point, 0.0, 0.3, 0.3)
Next
dbObj.Closed = True
sourceCol.Add(dbObj)
Dim dbObjs = Region.CreateFromCurves(sourceCol)
For Each obj In dbObjs
If TypeOf obj Is Region Then regions.Add(TryCast(obj, Region))
Next
Return regions
End Function
Public Function GetRegionFromLine(line As CadDb.Line) As List(Of Region)
Dim regions = New List(Of Region)()
Dim sourceCol = New DBObjectCollection()
' Create a parallel line
Dim offsetVector = (line.EndPoint - line.StartPoint).RotateBy(Math.PI / 2, New Vector3d(0, 0, 1)) * 0.1
Dim parallelLine = DirectCast(line.GetOffsetCurves(offsetVector.Length)(0), CadDb.Line)
' Create a polyline from the two lines
Dim poly = New CadDb.Polyline()
poly.AddVertexAt(0, New Point2d(line.StartPoint.X, line.StartPoint.Y), 0.0, 0.3, 0.3)
poly.AddVertexAt(1, New Point2d(line.EndPoint.X, line.EndPoint.Y), 0.0, 0.3, 0.3)
poly.AddVertexAt(2, New Point2d(parallelLine.EndPoint.X, parallelLine.EndPoint.Y), 0.0, 0.3, 0.3)
poly.AddVertexAt(3, New Point2d(parallelLine.StartPoint.X, parallelLine.StartPoint.Y), 0.0, 0.3, 0.3)
poly.Closed = True
sourceCol.Add(poly)
Dim dbObjs = Region.CreateFromCurves(sourceCol)
For Each obj In dbObjs
If TypeOf obj Is Region Then regions.Add(TryCast(obj, Region))
Next
Return regions
End Function
Private Function GetRegionFromEllipse(ellipse As CadDb.Ellipse) As List(Of Region)
Dim regions = New List(Of Region)()
Using tran = _dwg.TransactionManager.StartTransaction()
Dim tempEllipse = ellipse.Clone()
tempEllipse.TransformBy(Matrix3d.Displacement(ellipse.Center.GetVectorTo(Point3d.Origin)))
tran.AddNewlyCreatedDBObject(tempEllipse, True)
Dim outlineId = tempEllipse.GetOffsetCurves(0.001)(0)
Dim outline = tran.GetObject(outlineId, OpenMode.ForWrite)
tran.AddNewlyCreatedDBObject(outline, True)
If TypeOf outline Is CadDb.Polyline Then
regions.AddRange(GetRegionFromPolyline(TryCast(outline, CadDb.Polyline)))
ElseIf TypeOf outline Is CadDb.Arc Then
regions.AddRange(GetRegionFromArc(TryCast(outline, CadDb.Arc)))
End If
outline.Erase()
tempEllipse.Erase()
tran.Commit()
End Using
Return regions
End Function
Public Function GetRegionFromArc(arc As CadDb.Arc) As List(Of Region)
Dim regions = New List(Of Region)()
Dim sourceCol = New DBObjectCollection()
Dim dbObj = New CadDb.Polyline()
Dim numPoints As Integer = 100 ' increase this for higher precision
For i = 0 To numPoints
Dim param = arc.StartAngle + (arc.EndAngle - arc.StartAngle) * i / numPoints
Dim point = New Point2d(arc.Center.X + arc.Radius * Math.Cos(param), arc.Center.Y + arc.Radius * Math.Sin(param))
dbObj.AddVertexAt(i, point, 0.0, 0.3, 0.3)
Next
dbObj.AddVertexAt(numPoints + 1, New Point2d(arc.Center.X, arc.Center.Y), 0.0, 0.3, 0.3) ' add center point
dbObj.Closed = True
sourceCol.Add(dbObj)
Dim dbObjs = Region.CreateFromCurves(sourceCol)
For Each obj In dbObjs
If TypeOf obj Is Region Then regions.Add(TryCast(obj, Region))
Next
Return regions
End Function
Private Function GetRegionFromCurve(curve As CadDb.Curve) As List(Of Region)
Dim regions = New List(Of Region)()
Dim sourceCol = New DBObjectCollection()
Dim dbObj = DirectCast(curve.Clone(), CadDb.Curve)
sourceCol.Add(dbObj)
Dim dbObjs = Region.CreateFromCurves(sourceCol)
For Each obj In dbObjs
If TypeOf obj Is Region Then regions.Add(TryCast(obj, Region))
Next
Return regions
End Function
Private Function MergeRegions(regions As List(Of Region)) As Region
If regions.Count = 0 Then Return Nothing
If regions.Count = 1 Then Return regions(0)
Dim region = regions(0)
For i = 1 To regions.Count - 1
Dim rg = regions(i)
region.BooleanOperation(BooleanOperationType.BoolUnite, rg)
rg.Dispose()
Next
Return region
End Function
Private Function CreatePolyline(points As List(Of Point2d)) As CadDb.Polyline
Dim poly = New CadDb.Polyline(points.Count())
For i = 0 To points.Count - 1
poly.AddVertexAt(i, points(i), 0.0, 0.1, 0.1)
Next
poly.SetDatabaseDefaults(_dwg.Database)
poly.ColorIndex = 1
poly.Closed = True
Return poly
End Function
End Class
<CommandMethod("Outline")>
Public Sub RunMyCommand()
Dim dwg = Application.DocumentManager.MdiActiveDocument
Dim ed = dwg.Editor
Try
Dim ids = SelectEntities(ed)
If ids IsNot Nothing Then
Dim liner = New OutLiner(dwg)
liner.DrawOutline(ids)
Else
ed.WriteMessage(vbLf & "*Cancel*")
End If
Catch ex As System.Exception
ed.WriteMessage(vbLf & "Command failed:" & vbLf & "{0}", ex.Message)
ed.WriteMessage(vbLf & "*Cancel*")
End Try
End Sub
Private Function SelectEntities(ed As Editor) As ObjectId()
' Allow selection of all types of entities.
Dim res = ed.GetSelection()
If res.Status = PromptStatus.OK Then
Return res.Value.GetObjectIds()
Else
Return Nothing
End If
End Function
End Module
