(defun c:tt ()   
    (setvar "cmdecho" 0)
    (setvar "peditaccept" 1)
    (if (setq ss (ssget '((0 . "LINE,ARC,LWPOLYLINE,POLYLINE"))))
        (command "_pedit" "m" ss "" "j" "0.1" "")
    )
  (princ)
)

Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.ApplicationServices
Public Class 把直线和圆弧合并成PL '代码来自网络http://www.objectarx.net/foru ... wthread&tid=1466
    '把直线和圆弧合并成PL线
    <CommandMethod("ToPLTest")> _
    Sub MyPolyline()
        Dim Ed As Autodesk.AutoCAD.EditorInput.Editor = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.Editor
        Dim DocLock As DocumentLock = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument.LockDocument()
        Dim Values(0) As TypedValue
        Values.SetValue(New TypedValue(DxfCode.Start, "Line,Arc"), 0)
        Dim sFilter As SelectionFilter = New SelectionFilter(Values)
        Dim Opts As PromptSelectionOptions = New PromptSelectionOptions()
        Opts.MessageForAdding = "选择线与圆弧"
        Dim Res As PromptSelectionResult
        Res = Ed.GetSelection(Opts, sFilter)
        If Res.Status = PromptStatus.OK Then
            If Not Res.Value Is Nothing Then
                Dim SS As Autodesk.AutoCAD.EditorInput.SelectionSet = Res.Value
                Dim IDArray As ObjectId() = SS.GetObjectIds()
                Dim Obc As ObjectIdCollection = New ObjectIdCollection()
                For Each Id As ObjectId In IDArray
                    Obc.Add(Id)
                Next
                If Obc.Count > 1 Then
                    DwgPolyLine(Obc)
                    For Each Id As ObjectId In IDArray
                        Dim Db As Database = HostApplicationServices.WorkingDatabase
                        Using trans As Transaction = Db.TransactionManager.StartTransaction()
                            Dim Ent As Entity = trans.GetObject(Id, OpenMode.ForWrite, False)
                            Ent.Erase()
                            trans.Commit()
                        End Using
                    Next
                End If
            End If
        End If
        DocLock.Dispose()
    End Sub
    Private Sub DwgPolyLine(ByVal ObjectIdC As ObjectIdCollection) '画多段线 
        Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
        Dim Pl As New Polyline
        Dim tObjectId As ObjectIdCollection = ObjectIdC
        Dim WhileBo As Boolean = True
        Dim LName As String = ""
        Dim db As Database = HostApplicationServices.WorkingDatabase
        Using trans As Transaction = db.TransactionManager.StartTransaction()
            Dim E As Entity = trans.GetObject(tObjectId(0), OpenMode.ForRead)
            LName = E.Layer '获取第一个对象的图层，用来保持合并成的PL线，在原来的的图层上
        End Using
        Do While WhileBo
            For Each Id As ObjectId In tObjectId
                Using trans As Transaction = db.TransactionManager.StartTransaction()
                    Dim C As Curve = trans.GetObject(Id, OpenMode.ForWrite, False)
                    Dim EntName As String = C.GetType.Name
                    If Pl.NumberOfVertices = 0 Then
                        If EntName = "Arc" Then '如果是圆弧，设置polyline的凸起值 
                            Pl.AddVertexAt(0, C.StartPoint.Convert2d(New Plane), GetBulge(C, True), 0, 0)
                        Else
                            Pl.AddVertexAt(0, C.StartPoint.Convert2d(New Plane), 0, 0, 0)
                        End If
                        Pl.AddVertexAt(1, C.EndPoint.Convert2d(New Plane), 0, 0, 0)
                        tObjectId.Remove(Id) '该实体已经合并完，删除该实体ID在组数 
                        WhileBo = True
                        Exit For
                    Else
                        If C.StartPoint = Pl.GetPoint3dAt(0) Then
                            If EntName = "Arc" Then
                                Pl.AddVertexAt(0, C.EndPoint.Convert2d(New Plane), GetBulge(C, False), 0, 0)
                            Else
                                Pl.AddVertexAt(0, C.EndPoint.Convert2d(New Plane), 0, 0, 0)
                            End If
                            tObjectId.Remove(Id)
                            WhileBo = True
                            Exit For
                        ElseIf C.EndPoint = Pl.GetPoint3dAt(0) Then
                            If EntName = "Arc" Then
                                Pl.AddVertexAt(0, C.StartPoint.Convert2d(New Plane), GetBulge(C, True), 0, 0)
                            Else
                                Pl.AddVertexAt(0, C.StartPoint.Convert2d(New Plane), 0, 0, 0)
                            End If
                            tObjectId.Remove(Id)
                            WhileBo = True
                            Exit For
                        ElseIf C.StartPoint = Pl.GetPoint3dAt(Pl.NumberOfVertices - 1) Then
                            If EntName = "Arc" Then
                                Pl.SetBulgeAt(Pl.NumberOfVertices - 1, GetBulge(C, True))
                            End If
                            Pl.AddVertexAt(Pl.NumberOfVertices, C.EndPoint.Convert2d(New Plane), 0, 0, 0)
                            tObjectId.Remove(Id)
                            WhileBo = True
                            Exit For
                        ElseIf C.EndPoint = Pl.GetPoint3dAt(Pl.NumberOfVertices - 1) Then
                            If EntName = "Arc" Then
                                Pl.SetBulgeAt(Pl.NumberOfVertices - 1, GetBulge(C, False))
                            End If
                            Pl.AddVertexAt(Pl.NumberOfVertices, C.StartPoint.Convert2d(New Plane), 0, 0, 0)
                            tObjectId.Remove(Id)
                            WhileBo = True
                            Exit For
                        Else
                            WhileBo = False
                        End If
                    End If
                    trans.Commit()
                End Using
            Next
            If tObjectId.Count < 1 Then
                WhileBo = False
            End If
        Loop
        Pl.Layer = LName
        DrawEntity(Pl) '把新建的PolyLine加到数据库
        If tObjectId.Count > 0 Then '判断是否把线与圆弧合并完 
            DwgPolyLine(tObjectId)
        End If
    End Sub
    '计算凸起值
    Private Function GetBulge(ByVal A As Arc, ByVal SEbo As Boolean) As Double
        Dim Bulge As Double
        Dim L1 As Double = A.StartPoint.GetVectorTo(A.EndPoint).Length
        Dim Angle As Double = A.EndAngle - A.StartAngle
        If Angle < 0 Then
            Angle = Math.PI * 2 + Angle '计算圆弧总角度 
        End If
        If Angle > Math.PI Then '判断是否大于180度 
            Bulge = A.Radius + Math.Sqrt(A.Radius ^ 2 - (L1 / 2) ^ 2) '计算凸起值 
        Else
            Bulge = A.Radius - Math.Sqrt(A.Radius ^ 2 - (L1 / 2) ^ 2) '计算凸起值 
        End If
        Dim Pt2 As Point3d = A.GetPointAtDist(A.GetDistanceAtParameter(A.EndParam) / 2) '取中点 
        Dim TempDouble As Double
        If SEbo = True Then '判断方向 
            TempDouble = PtSide(A.StartPoint, Pt2, A.EndPoint)
        Else
            TempDouble = PtSide(A.EndPoint, Pt2, A.StartPoint)
        End If
        If TempDouble > 0 Then '判断圆弧是凸向哪边 
            Return -Bulge / (L1 / 2)
        ElseIf TempDouble < 0 Then
            Return Bulge / (L1 / 2)
        End If
    End Function
    '判断圆弧是凸向哪边 
    Private Shared Function PtSide(ByVal pt1 As Point3d, ByVal pt2 As Point3d, ByVal pt3 As Point3d) As Double
        Dim vect1 As Vector3d = pt1.GetVectorTo(pt2)
        Dim vect2 As Vector3d = pt1.GetVectorTo(pt3)
        Return vect2.X * vect1.Y - vect1.X * vect2.Y
    End Function
    Public Function DrawEntity(ByVal ent As Entity) As ObjectId '加入实体到数据库
        Dim ed As Editor = Application.DocumentManager.MdiActiveDocument.Editor
        Try
            Dim db As Database = HostApplicationServices.WorkingDatabase
            Using trans As Transaction = db.TransactionManager.StartTransaction()
                Dim bt As BlockTable = DirectCast(trans.GetObject(db.BlockTableId, OpenMode.ForRead), BlockTable)
                Dim btr As BlockTableRecord = DirectCast(trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
                btr.AppendEntity(ent)
                trans.AddNewlyCreatedDBObject(ent, True)
                trans.Commit()
            End Using
            Return ent.ObjectId
        Catch ex As Exception
            ed.WriteMessage(ex.Message)
            Return ObjectId.Null
        End Try
    End Function
End Class