Author Topic: Merge polylines using SendCommand VB.NET  (Read 1017 times)

0 Members and 1 Guest are viewing this topic.

Offline fixo

  • Full Member
  • ***
  • Posts: 135
  • Karma: +4/-0
  • Gender: Male
    • prefered language: C
    • Prog expertise: Good
    • View Profile
Merge polylines using SendCommand VB.NET
« on: April 21, 2013, 01:01:59 PM »
    Here is the basic command to merge / subtract closed contours,
   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