11
Polylines / Merge polylines using SendCommand VB.NET
« Last post by fixo on April 21, 2013, 01:01:59 PM » Here is the basic command to merge / subtract closed contours,
tested on A2010
VB.NET
tested on A2010
VB.NET
Code: [Select]
<CommandMethod("mep", CommandFlags.Session)> _
Public Shared Sub testUnionPlines()
Dim doc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
Dim ed As Editor = doc.Editor
Dim db As Database = doc.Database
' get argument to choose boolean operation mode
Dim pko As New PromptKeywordOptions(vbLf & "Choose boolean operation mode " & "[Union/Subtract]: ", "Union Subtract")
' The default depends on our current settings
pko.Keywords.[Default] = "Union"
Dim pkr As PromptResult = ed.GetKeywords(pko)
If pkr.Status <> PromptStatus.OK Then
Return
End If
Dim choice As String = pkr.StringResult
Dim doUnion As Boolean = If(choice = "Union", True, False)
Dim regLst As New List(Of Region)()
Dim delPline As New List(Of Polyline)()
Using doclock As DocumentLock = doc.LockDocument()
'start a transaction
Using tr As Transaction = db.TransactionManager.StartTransaction()
Dim tvs As TypedValue() = New TypedValue(2) {New TypedValue(0, "lwpolyline"), New TypedValue(-4, "&"), New TypedValue(70, 1)}
Dim filter As New SelectionFilter(tvs)
Dim pso As New PromptSelectionOptions()
pso.MessageForRemoval = vbLf & "Select closed polylines only: "
pso.MessageForAdding = vbLf & "Select closed polylines: "
Dim result As PromptSelectionResult = ed.GetSelection(filter)
If result.Status <> PromptStatus.OK Then
Return
End If
Try
Dim sset As SelectionSet = result.Value
Dim ids As ObjectId() = sset.GetObjectIds()
Dim btr As BlockTableRecord = DirectCast(tr.GetObject(db.CurrentSpaceId, OpenMode.ForWrite, False), BlockTableRecord)
Dim objreg1 As New Region()
For n As Integer = 0 To ids.Count() - 1
Dim obj As DBObject = TryCast(tr.GetObject(ids(n), OpenMode.ForRead), DBObject)
Dim pline1 As Polyline = TryCast(obj, Polyline)
If pline1 Is Nothing Then
Return
End If
' Add the polyline to the List to rerase them all at the end of execution
delPline.Add(pline1)
' Add the polyline to the array
Dim objArray1 As New DBObjectCollection()
objArray1.Add(pline1)
' create the 1 st region
Dim objRegions1 As New DBObjectCollection()
objRegions1 = Region.CreateFromCurves(objArray1)
objreg1 = TryCast(objRegions1(0), Region)
btr.AppendEntity(objreg1)
tr.AddNewlyCreatedDBObject(objreg1, True)
objreg1.ColorIndex = 1
'optional
' add the region to the List<Region> for the future work
regLst.Add(objreg1)
Next
'ed.WriteMessage("\nCount regions:\t{0}\n", regLst.Count);//just for the debug
' sort regions by areas
Dim items As Region() = regLst.ToArray()
Array.Sort(items, Function(x As Region, y As Region) y.Area.CompareTo(x.Area))
' get the biggest region first
Dim mainReg As Region = items(0)
' ed.WriteMessage("\nMain region area:\t{0:f3}\n", items[0].Area);//just for the debug
If Not mainReg.IsWriteEnabled Then
mainReg.UpgradeOpen()
End If
If items.Length = 2 Then
If Not doUnion Then
mainReg.BooleanOperation(BooleanOperationType.BoolSubtract, DirectCast(items(1), Region))
Else
mainReg.BooleanOperation(BooleanOperationType.BoolUnite, DirectCast(items(1), Region))
End If
Else
' starting iteration from the second region
Dim i As Integer = 1
Do
Dim reg1 As Region = items(i)
Dim reg2 As Region = items(i + 1)
If (reg1 Is Nothing) OrElse (reg2 Is Nothing) Then
Exit Do
Else
' subtract region 1 from region 2
If reg1.Area > reg2.Area Then
' subtract the smaller region from the larger one
'
reg1.BooleanOperation(BooleanOperationType.BoolUnite, reg2)
If Not doUnion Then
mainReg.BooleanOperation(BooleanOperationType.BoolSubtract, reg1)
Else
mainReg.BooleanOperation(BooleanOperationType.BoolUnite, reg1)
End If
Else
' subtract the smaller region from the larger one
reg2.BooleanOperation(BooleanOperationType.BoolUnite, reg1)
If Not doUnion Then
mainReg.BooleanOperation(BooleanOperationType.BoolSubtract, reg2)
Else
mainReg.BooleanOperation(BooleanOperationType.BoolUnite, reg2)
End If
End If
End If
' increase counter
i += 1
Loop While i < items.Length - 1
End If
mainReg.ColorIndex = 1
' put dummy color for region
' erase polylines
For Each poly As Polyline In delPline
If poly IsNot Nothing Then
If Not poly.IsWriteEnabled Then
poly.UpgradeOpen()
End If
poly.Erase()
If Not poly.IsDisposed Then
poly.Dispose()
End If
End If
Next
' --- explode region and create polyline from exploded entities --- //
Dim regexpl As New DBObjectCollection()
mainReg.Explode(regexpl)
Dim exids As New List(Of ObjectId)()
' gather selected object into the List<ObjectId>
If regexpl.Count > 0 Then
For Each obj As DBObject In regexpl
Dim ent As Entity = TryCast(obj, Entity)
If ent IsNot Nothing Then
Dim eid As ObjectId = btr.AppendEntity(ent)
tr.AddNewlyCreatedDBObject(ent, True)
exids.Add(eid)
End If
Next
End If
' define AcadDocument as object
Dim ActiveDocument As Object = doc.AcadDocument
Dim entids As ObjectId() = New ObjectId() {}
Array.Resize(entids, exids.Count)
' convert List<ObjectId> to array of ObjectID
exids.CopyTo(entids, 0)
ed.Regen()
' create a new selection set and exploded items
Dim newset As SelectionSet = SelectionSet.FromObjectIds(entids)
ed.SetImpliedSelection(newset.GetObjectIds())
Dim pfres As PromptSelectionResult = ed.SelectImplied()
' execute Sendcommand synchronously
ActiveDocument.GetType().InvokeMember("SendCommand", System.Reflection.BindingFlags.InvokeMethod, Nothing, ActiveDocument, New Object() {"select" & vbLf})
' execute Sendcommand synchronously
Dim cmd As String = "_pedit _M _P" & " " & "" & " " & "_J" & " " & "" & " " & "" & vbLf
ActiveDocument.GetType().InvokeMember("SendCommand", System.Reflection.BindingFlags.InvokeMethod, Nothing, ActiveDocument, New Object() {cmd})
' rerase region if this is do not erased (relative to current DELOBJ variable value)
If mainReg IsNot Nothing Then
If Not mainReg.IsWriteEnabled Then
mainReg.UpgradeOpen()
End If
End If
mainReg.Erase()
tr.Commit()
Catch ex As Autodesk.AutoCAD.Runtime.Exception
ed.WriteMessage((vbLf & "AutoCAD exception:" & vbLf + ex.Message & vbLf) + ex.StackTrace)
Finally
'optional, might be removed
ed.WriteMessage(vbLf & "{0}", New Autodesk.AutoCAD.Runtime.ErrorStatus().ToString())
End Try
End Using
End Using
End Sub
Recent Posts