'***********************************************************************

'给多义线增加顶点*********************************************************'
Sub AddPointToPline()
    Dim PL As AcadLWPolyline
    Dim PickPnt As Variant
    'On Error Resume Next
    ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
    
    Dim P As Variant                                        '多义线顶点数组
    P = PL.Coordinates
    Dim PS As AcadPoint
    Dim PE As AcadPoint
    Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
    PS.color = acBlue
    Dim L As Integer
    L = UBound(P)
    Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
    PE.color = acRed
    
    Dim TempPoint1 As Variant                               '点取多义线上的一点，此点将在添加点（TempPoint2）之前
    Dim TempPoint2 As Variant                               '点取一点，此点就是要添加的点，在多义线中排在TempPoint1点之后
ChongXinXuanZe:
    ThisDrawing.Utility.InitializeUserInput 1, ""
    TempPoint1 = ThisDrawing.Utility.GetPoint(, "选择多义线的一个顶点(预添加点的前一个点): ")
    Dim k As Integer
    Dim I As Integer
    '如果点不在是多段线的顶点，则重新选择点
    For I = 0 To UBound(P) - 1
        If P(I) = TempPoint1(0) And P(I + 1) = TempPoint1(1) Then k = I + 2: Exit For
    Next
    If k = 0 Then
       ThisDrawing.Utility.Prompt "你选择的点不是多义线的顶点请重新选择。" & Chr(13)
       GoTo ChongXinXuanZe
    End If
    
    ThisDrawing.Utility.InitializeUserInput 1, ""
    TempPoint2 = ThisDrawing.Utility.GetPoint(TempPoint1, "选择要添加的点: ")
    '重新定义数值
    Dim P1() As Double
    ReDim P1(UBound(P) + 2)
    '将点坐标插入到数组中
    For I = 0 To k - 1
        P1(I) = P(I)
    Next
    P1(k) = TempPoint2(0): P1(k + 1) = TempPoint2(1)
    For I = k + 2 To UBound(P) + 2
        P1(I) = P(I - 2)
    Next
    '重新绘制多段线
    Dim XPL As AcadLWPolyline
    Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(P1)
    '特性匹配多段线
    XPL.Layer = PL.Layer
    XPL.color = PL.color
    Dim SW As Double
    Dim EW As Double
    For I = 0 To Int(L / 2) - 1
        PL.GetWidth I, SW, EW
        XPL.SetWidth I, SW, EW
    Next
    XPL.SetWidth I, SW, EW
    XPL.SetWidth I + 1, SW, EW
    If PL.Closed = True Then XPL.Closed = True
    '删除原来的多段线和起点及终点
    PL.Delete
    PS.Delete
    PE.Delete
    
End Sub

Sub L2PL()
    Dim objSelected As Object
    Dim L  As AcadLine
    Dim Pl As AcadLWPolyline
    Dim XuanZeJi As AcadSelectionSet
    Dim i As Long
    Dim P() As Double
    On Error GoTo E
    Set XuanZeJi = ThisDrawing.SelectionSets.Add("xline")
    '定义过滤机制
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    FilterType(0) = 0
    FilterData(0) = "line"
    
    ThisDrawing.Utility.Prompt "请按顺序选择线段:" & Chr(13)
    
    XuanZeJi.SelectOnScreen FilterType, FilterData
    ReDim Preserve P(XuanZeJi.Count * 4 - 1)
    
    '对选择集中的线段进行操作
    For Each objSelected In XuanZeJi
        If TypeOf objSelected Is AcadLine Then
            Set L = objSelected
            P(i) = L.StartPoint(0)
            P(i + 1) = L.StartPoint(1)
            P(i + 2) = L.EndPoint(0)
            P(i + 3) = L.EndPoint(1)
            i = i + 4
        Else
            '删除选择集
            ThisDrawing.SelectionSets.item("xline").Delete
        End If
    Next
    Set Pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(P)
    For i = 0 To XuanZeJi.Count * 2 - 1
        Pl.SetWidth i, 1, 1
    Next i
    ThisDrawing.SelectionSets.item("xline").Delete
    ThisDrawing.Application.Update
    Exit Sub
E:
        ThisDrawing.SelectionSets.item("xline").Delete

End Sub