如何用VBA连接相邻的长折线？

Sub JoininJoininJoinin()
'Get them plines joinin'
'This song is quite anoyin'
'raw code
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim intGroup(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim intcnt As Integer
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
  If objSelSet.Name = "PolyJoin" Then
    objSelSets.Item(objSelSet.Name).Delete
    Exit For
  End If
Next objSelSet
intGroup(0) = 0: varData(0) = "LWPolyline": intGroup(1) = 8: varData(1) = "LayerName"
Set objSelSet = objSelSets.Add("PolyJoin")
objSelSet.Select acSelectionSetAll, , , intGroup, varData
For intcnt = 1 To objSelSet.Count - 1
  MeJoinPline objSelSet.Item(0), objSelSet.Item(intcnt), 0.01
Next intcnt
End Sub

Option Explicit
Declare Function GetCursor Lib "user32" () As Long
Public Declare Function GetAsyncKeyState Lib "user32" _
        (ByVal vKey As Long) As Integer
Public Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" _
    (dest As Any, source As Any, ByVal Length As Long) 'AlmostEqual
Private DeleteCol As Collection
Private StartEndCol As Collection
Private SlopeCol As Collection
Private CoordList As Collection
Private Const PolyClosedFudge As Double = 0.005
'If the first coordinate and last coordinate are within this distance
'The poly will be closed.
Const Pi As Double = 3.14159265358979
Public Property Get CurrentSpace() As AcadBlock
  If ThisDrawing.GetVariable("CVPORT") = 1 Then
    Set CurrentSpace = ThisDrawing.PaperSpace
  Else
    Set CurrentSpace = ThisDrawing.ModelSpace
  End If
End Property
'Aims
'1) To select a group of lines,arcs and polys
'and create clean polys w/ no double ups
'or double points.
'2) Delete unnecessary geometry
'Some will want to add a layer control here.
'3) Note 2d and 3dpolys are not included
'4) I have used line formulas rather than polar angles
'hoping that it will be faster.
Sub VBAPLJoin()
    'On Error GoTo Err_Control
    Dim oLine As AcadLine
    Dim LineCol As New Collection
    Dim oPline As AcadLWPolyline
    Dim CoordsCt As Integer
    Dim oArc As AcadArc
    Dim oSSets As AcadSelectionSets
    Dim ss As AcadSelectionSet
    Dim FilterType(6) As Integer
    Dim FilterData(6) As Variant
    Dim i As Integer, j As Integer, k As Integer
    Dim intNotParallel As Integer
    Dim PtsCount As Integer, Count As Integer
    Dim StartPt As Variant, EndPt As Variant
    Dim StartP(2) As Double, EndP(2) As Double
    Dim Pt As Variant
    Dim pts() As Double
    Dim SE(4) As Variant
    Dim obj(0) As AcadEntity
    Dim M As Double, OrigY As Double
    Dim UcsNormal As Variant, N As Variant
    Dim blnRemove As Boolean
    Dim dblElev As Double
    Dim strlayer As String
    Dim util As AcadUtility
    PtsCount = 1
    Set util = ThisDrawing.Utility
    Set StartEndCol = New Collection
        
    'Stage 1  Create the selectionset
    Set oSSets = ThisDrawing.SelectionSets
    For Each ss In oSSets
        If ss.Name = "SS" Then
            ss.Delete
            Exit For
        End If
    Next
    Set ss = oSSets.Add("SS")
    
    
    FilterType(0) = 0: FilterData(0) = "Line,Arc,LWPolyline"
    FilterType(1) = -4: FilterData(1) = ""
    FilterType(6) = -4: FilterData(6) = "NOT>"
    
     Do ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
        ss.SelectOnScreen FilterType:=FilterType, FilterData:=FilterData
    Loop Until GetCursor = 0
   
    If ss.Count > 500 Then
        MsgBox "You have selected " & ss.Count & " objects. Please select less :"
        Exit Sub
    End If
    If ss.Count = 0 Then
        Set ss = Nothing
        ''''''''''''MsgBox "Nothing selected."
        Exit Sub
    End If
    If ss.Count = 1 Then
        If TypeOf ss(0) Is AcadLWPolyline Then
            Set oPline = ss(0)
            If UBound(oPline.Coordinates) = 3 Then
                Exit Sub
            End If
        End If
    End If
    UcsNormal = CurrentUcsNormal
    'We're using the SS set index to keep track of the objects
    'So first pass is just to clean up the set
    'From then on the order wont change
    
    'Stage 2- delete zero length ents, remove non applicable ents
     For i = ss.Count - 1 To 0 Step -1
        If TypeOf ss(i) Is AcadLine Then
            Set oLine = ss(i)
            If oLine.Length  0 Then
        CheckLines LineCol 'Sub checks for equal, overlapping lines
    End If
    If ss.Count = 0 Then 'items may have been removed
        Exit Sub
    End If
    If intNotParallel = 1 Then
        MsgBox intNotParallel & " object was not parallel to the current UCS."
    ElseIf intNotParallel > 1 Then
        MsgBox intNotParallel & " objects were not parallel to the current UCS."
    End If
    
    'Stage 5
    'This function sorts the start and end points into order
    If StartEndCol.Count > 1 Then
        SortPts
    End If
    
    Dim blnClosed As Boolean, blnNewLine As Boolean
    Dim BulgeCol() As Double, PolyBulgeCol() As Double
    Dim MPt(2) As Double, Seg As Double, Ht As Double
    Dim sPt, ePt
    ReDim pts(1)
AddNewLine:
    
    Count = StartEndCol.Count
    j = 0
    If Count > 1 Then
        For i = 1 To Count
            If StartEndCol(i)(2) = "NewLine" Then
                j = i - 1
                Exit For
            End If
        Next
        If j = 0 Then j = Count
        If EqualPts(StartEndCol(1)(0), StartEndCol(j)(1)) Then
            blnClosed = True
        End If
    End If
    
    N = ss(StartEndCol(1)(2)).Normal
    dblElev = ElevationFromPt(StartEndCol(1)(0), N) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    strlayer = ss(StartEndCol(1)(2)).Layer
    'Stage 6
    'Draw a pline for each set of continuous points
    'NewLine signifies there are no more points to add
    'to the last poly so a new poly is reqd.
    
    
    sPt = StartEndCol(1)(0)
    sPt = util.TranslateCoordinates(sPt, acWorld, acOCS, 1, N)
    pts(0) = sPt(0)
    pts(1) = sPt(1)
    PtsCount = 1
    For i = 1 To StartEndCol.Count
        If StartEndCol(i)(2) = "NewLine" Then
            StartEndCol.Remove i
            blnNewLine = True
            Exit For
        End If
        
        If TypeOf ss(StartEndCol(i)(2)) Is AcadArc Then
            Set oArc = ss(StartEndCol(i)(2))
            ePt = StartEndCol(i)(1)
            ePt = util.TranslateCoordinates(ePt, acWorld, acOCS, 1, N)
                       
            ReDim Preserve pts(PtsCount + 2)
            pts(PtsCount + 1) = ePt(0)
            pts(PtsCount + 2) = ePt(1)
            'Now get the bulge
            sPt = ToUcs(oArc.Startpoint): ePt = ToUcs(oArc.Endpoint)
            Dim CPt As Variant
            CPt = ToUcs(oArc.Center)
            MPt(0) = sPt(0) + ((ePt(0) - sPt(0)) / 2)
            MPt(1) = sPt(1) + ((ePt(1) - sPt(1)) / 2)
            MPt(2) = sPt(2)
            Seg = (Length(sPt, ePt)) / 2
            If oArc.TotalAngle > Pi Then
                Ht = (2 * oArc.radius) - (oArc.radius - Length(CPt, MPt))
            Else
                Ht = oArc.radius - Length(CPt, MPt)
            End If
            ReDim Preserve BulgeCol((PtsCount - 1) / 2)
             If EqualPts(oArc.Startpoint, StartEndCol(i)(0)) Then
            
                BulgeCol((PtsCount - 1) / 2) = Ht / Seg 'Bulge
            Else
                BulgeCol((PtsCount - 1) / 2) = -Ht / Seg
                            
            End If
            PtsCount = PtsCount + 2
            StartEndCol.Remove i
            i = i - 1
            GoTo Skip3
        End If
        If TypeOf ss(StartEndCol(i)(2)) Is AcadLine Then
PlineLine:
            ePt = StartEndCol(i)(1)
            ePt = util.TranslateCoordinates(ePt, acWorld, acOCS, 1, N)
            'addpt EPt, , 2
            ReDim Preserve pts(PtsCount + 2)
            pts(PtsCount + 1) = ePt(0)
            pts(PtsCount + 2) = ePt(1)
            ReDim Preserve BulgeCol((PtsCount - 1) / 2)
            BulgeCol((PtsCount - 1) / 2) = 0
            PtsCount = PtsCount + 2
            StartEndCol.Remove i
            i = i - 1
            GoTo Skip3
        End If
        If TypeOf ss(StartEndCol(i)(2)) Is AcadLWPolyline Then
            Set oPline = ss(StartEndCol(i)(2))
            CoordsCt = (UBound(oPline.Coordinates) - 1) / 2
            If CoordsCt = 1 Then
                If oPline.GetBulge(0) = 0 Then
                    GoTo PlineLine
                End If
            End If
            Dim Coord, coords()
            ReDim coords(CoordsCt)
            ReDim PolyBulgeCol(CoordsCt - 1)
            For j = 0 To 1
                StartPt(j) = oPline.Coordinates(j)
            Next j
            StartPt(2) = oPline.Elevation
            Pt = util.TranslateCoordinates(StartPt, acOCS, acWorld, 1, oPline.Normal)
            If Not EqualPts(Pt, StartEndCol(i)(0)) Then 'swap''''''''''''''''''
                k = 0
                For j = CoordsCt To 0 Step -1
                    coords(k) = oPline.Coordinate(j)
                    k = k + 1
                Next
                k = 0
                For j = CoordsCt - 1 To 0 Step -1
                    PolyBulgeCol(k) = -oPline.GetBulge(j)
                    k = k + 1
                Next
            Else
                For j = 0 To CoordsCt
                    coords(j) = oPline.Coordinate(j)
                Next
                For j = 0 To CoordsCt - 1
                    PolyBulgeCol(j) = oPline.GetBulge(j)
                Next
                
            End If
            ReDim Preserve pts(PtsCount + (CoordsCt * 2))
            For j = 1 To CoordsCt 'We already have the first pair
            
                pts(PtsCount + 1) = coords(j)(0)
                pts(PtsCount + 2) = coords(j)(1)
                ReDim Preserve BulgeCol((PtsCount - 1) / 2)
                BulgeCol((PtsCount - 1) / 2) = PolyBulgeCol(j - 1)
                PtsCount = PtsCount + 2
            Next
            StartEndCol.Remove i
            i = i - 1
            GoTo Skip3
        End If
Skip3:
        If StartEndCol.Count = 0 Then
            Exit For
        End If
    Next i
    
    
    If blnClosed Then
        ReDim Preserve pts(PtsCount - 2)
    End If
    
    Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pts)
    oPline.Elevation = dblElev
    'oPline.Normal = N ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'oPline.Color = acMagenta
    oPline.Layer = strlayer
    For i = 0 To UBound(BulgeCol)
        oPline.SetBulge i, BulgeCol(i)
    Next
    If blnClosed Then
        oPline.Closed = True
    Else
        PolyVertexCheck oPline ''''''''''''''''''''''''''''''''''
    End If
    
    
    If blnNewLine Then
        blnNewLine = False
        blnClosed = False
        If StartEndCol.Count > 0 Then
            GoTo AddNewLine
        End If
    End If
    
    ss.Erase 'Delete the selection set leaving us w/ nice new polys
    ss.Delete
Exit_Here:
    Exit Sub
Err_Control:
    Select Case Err.Number
    'Add your Case selections here
        Case Else
        MsgBox Err.Description
        Err.Clear
        Resume Exit_Here
    End Select
End Sub

Function GetSlope(DeltaX, DeltaY, StartPt As Variant, _
                M As Double, OrigY As Double) As Integer
    DeltaX = CDbl(DeltaX)
    DeltaY = CDbl(DeltaY)
    If Rd(DeltaY, 0) Then   'Line is horizontal
        M = 0
        OrigY = StartPt(1)
        GetSlope = 0
    ElseIf Rd(DeltaX, 0) Then  'Line is vertical
        M = StartPt(0)
        OrigY = 0
        GetSlope = 1
    Else
        M = DeltaY / DeltaX
        OrigY = StartPt(1) - (M * StartPt(0))
        GetSlope = 2
    End If
End Function
Private Function SortPts()
    
    Dim A As Variant, b As Variant
    Dim StartPt As Variant, EndPt As Variant
    Dim NextStartPt As Variant, NextEndPt As Variant
    Dim NewStartEndCol As New Collection
    Dim blnRemoved As Boolean
    Dim intBefore As Integer
    Dim i As Integer
    
    intBefore = 1
    A = StartEndCol(1)
    StartPt = A(0): EndPt = A(1)
    NewStartEndCol.Add A
    StartEndCol.Remove 1
    Do While StartEndCol.Count > 0
Removed:
        blnRemoved = False
        For i = StartEndCol.Count To 1 Step -1
            
            NextStartPt = StartEndCol(i)(0)
            NextEndPt = StartEndCol(i)(1)
            
            If EqualPts(StartPt, NextStartPt) Then
                StartPt = NextEndPt
                A = StartEndCol(i)
                'swap start and end points
                A(0) = NextEndPt
                A(1) = NextStartPt
                NewStartEndCol.Add A, , intBefore
                blnRemoved = True
                GoTo skip
            End If
            If EqualPts(StartPt, NextEndPt) Then
                StartPt = NextStartPt
                A = StartEndCol(i)
                NewStartEndCol.Add A, , intBefore
                blnRemoved = True
                GoTo skip
            End If
            If EqualPts(EndPt, NextStartPt) Then
                EndPt = NextEndPt
                A = StartEndCol(i)
                NewStartEndCol.Add A
                blnRemoved = True
                GoTo skip
            End If
            If EqualPts(EndPt, NextEndPt) Then
                    EndPt = NextStartPt
                    A = StartEndCol(i)
                    'swap start and end points
                    A(0) = NextEndPt
                    A(1) = NextStartPt
                    NewStartEndCol.Add A
                    blnRemoved = True
                    GoTo skip
            End If
            
skip:
            If blnRemoved Then
                StartEndCol.Remove i
                GoTo Removed
            End If
        Next
        
        If blnRemoved = False Then
            If StartEndCol.Count > 0 Then
                A(2) = "NewLine"
                NewStartEndCol.Add A
                A = StartEndCol(1)
                StartPt = A(0): EndPt = A(1)
                NewStartEndCol.Add A
                intBefore = NewStartEndCol.Count
                StartEndCol.Remove 1
            End If
         End If
    Loop
        
    
    For i = 1 To NewStartEndCol.Count
        StartEndCol.Add NewStartEndCol(i)
    Next
End Function

'Rules used
'1)identical-
'   delete one
'2)line within line-and no arms off the smaller-delete smaller
        'if within has arm and the larger doesn't-remove the larger
        'intWithin 1=start equal,2=end equal,3=neither
'3)Overlapping
    'if no arms off the inside pts then delete both, add one long line
    'intWithin=4
Private Sub CheckLines(LineCol As Collection)
    Dim oLine As AcadLine
    Dim Si  As Variant, Sj  As Variant, varSE  As Variant
    Dim blnSti As Boolean, blnStj As Boolean
    Dim blnEndi As Boolean, blnEndj As Boolean
    Dim Starti As Variant, Endi As Variant
    Dim Startj As Variant, Endj As Variant
    Dim i As Integer, j As Integer, k As Integer
    Dim intWithin As Integer '1=start equal,2=end equal,3=neither
    Dim blnRemoved As Boolean
    Dim intVertical As Integer
    
    For i = LineCol.Count To 1 Step -1 'allows removal from set
        Si = LineCol(i)
        Starti = Si(0): Endi = Si(1)
        'now do the expensive point checks we will need to
        'check if a line has an arm coming off it
        'we only want to do this once
        blnSti = PtCheck(Starti, i)
        blnEndi = PtCheck(Endi, i)
        For j = LineCol.Count To 1 Step -1
            blnRemoved = False
            If Not j = i Then
                If Rd(LineCol(j)(4), LineCol(i)(4)) Then 'Check origY values
                    If Rd(LineCol(j)(3), LineCol(i)(3)) Then  'Check slope values
                    'Check z values''''''''''''''''''''''''''''''''
                        Sj = LineCol(j)
                        Startj = Sj(0): Endj = Sj(1)
            
                        'now we dont have to factor in Line direction
                        'Make i the most left or the lowest
                        If Startj(0)  Endi(0) Or Startj(1) > Endi(1) Then
                            GoTo skip 'Get it the next time
                        End If
                     
                        'Check for identical
                        If Rd(Startj(0), Starti(0)) And Rd(Endj(0), Endi(0)) Then   'Could be vertical
                            If Rd(Startj(1), Starti(1)) Then
                                If Rd(Endj(1), Endi(1)) Then   'identical
                                    DeleteIt LineCol, j
                                    blnRemoved = True
                                    'i = i - 1
                                    GoTo skip
                                 End If
                            End If
                        End If
        
                        intWithin = 0
                        intVertical = 0
                        'Check for within or overlapping
                        'Do the verticals first
                        If Rd(Startj(0), Starti(0)) And Rd(Endj(0), Endi(0)) Then  'vertical now
                            intVertical = 1
                            If Rd(Startj(1), Starti(1)) Then
                                intWithin = 1
                            End If
                            If Startj(1) > Starti(1) Then
                                If Endj(1)  i Then ''''''''''''''''
                                                j = j - 1
                                            End If
                                            DeleteIt LineCol, j
                                            LineCol.Add Si
                                            StartEndCol.Add Si
                                            'i = i - 1
                                            GoTo skip
                                        End If
                                    End If
                                End If
                            End If
                            GoTo BranchControl
                        End If
                                
                        'Now horiz. lines and the rest
                        If Rd(Startj(0), Starti(0)) Then
                            intWithin = 1
                            GoTo BranchControl
                        End If
                        
                        If Startj(0) > Starti(0) Then
                            If Endj(0)  i Then
                                            j = j - 1
                                        End If
                                        DeleteIt LineCol, j
                                        LineCol.Add Si
                                        StartEndCol.Add Si
                                        'i = i - 1
                                        GoTo skip
                                    End If
                                End If
                            End If
                        End If
                        
                        If intWithin = 0 Then GoTo skip
                
BranchControl:
                        'now do the expensive point checks we will need to
                        'check if a line has an arm coming off it
                        'we only want to do this once
                        blnStj = PtCheck(Startj, j)
                        blnEndj = PtCheck(Endj, j)
    
                        If intWithin = 4 Then 'overlapping
                            If Not blnStj And Not blnEndi Then 'make one line
                                Si = LineCol(i)
                                Si(1) = Endj
                                DeleteIt LineCol, i
                                blnRemoved = True
                                If j > i Then ''''''''''''''''
                                    j = j - 1
                                End If
                                DeleteIt LineCol, j
                                LineCol.Add Si
                                StartEndCol.Add Si
                                'i = i - 1
                                GoTo skip
                            End If
                        End If
                        
                        If intWithin = 1 Then
                            If Endj(intVertical)  i Then
                j = j - 1
            End If
            If i > j Then
                i = i - 1
            End If
        End If
        Next j
    Next i
 
End Sub
Private Sub DeleteIt(COL As Collection, i As Integer)
    'Add layermanagement here if you need it.
    Dim k As Integer
    For k = 1 To StartEndCol.Count
        If StartEndCol(k)(2) = COL(i)(2) Then
            StartEndCol.Remove k
            Exit For
        End If
    Next
    COL.Remove i
End Sub
Function SortStartEnd(StartPt, EndPt)
    Dim varPt As Variant
    If EndPt(0) - StartPt(0) > 0.00000001 Then
    'If StartPt(0)  EndPt(1) Then
                 varPt = StartPt
                 StartPt = EndPt
                 EndPt = varPt
            Else
                Exit Function
            End If
        Else
            varPt = StartPt
            StartPt = EndPt
            EndPt = varPt
        End If
    End If
End Function
Function CurrentUcsNormal() As Variant
    Dim UcsX, UcsY, UcsZ(2) As Double
    UcsX = ThisDrawing.GetVariable("Ucsxdir")
    UcsY = ThisDrawing.GetVariable("Ucsydir")
    'get CrossProduct
    UcsZ(0) = UcsX(1) * UcsY(2) - UcsX(2) * UcsY(1)
    UcsZ(1) = UcsX(2) * UcsY(0) - UcsX(0) * UcsY(2)
    UcsZ(2) = UcsX(0) * UcsY(1) - UcsX(1) * UcsY(0)
    CurrentUcsNormal = UcsZ
    'Debug.Print UcsZ(0), UcsZ(1), UcsZ(2)
End Function
Function ToUcs(Pt As Variant) As Variant
    ToUcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acWorld, acUCS, False)
End Function
Function ToWcs(Pt As Variant) As Variant
    ToWcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acUCS, acWorld, False)
End Function
Function Rd(num1 As Variant, num2 As Variant) As Boolean
    Dim dRet As Double
    dRet = num1 - num2
    If Abs(dRet)  2 Or i  0 Then
            Stx = Startpoint(0): Sty = Startpoint(1)
            Enx = Endpoint(0): Eny = Endpoint(1)
            dX = Stx - Enx
            dY = Sty - Eny
            If i = 1 Then
                Length = Sqr(dX * dX + dY * dY)
            Else
                Stz = Startpoint(2): Enz = Endpoint(2)
                dZ = Stz - Enz
                Length = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))
            End If
        Else
            Exit Function
        End If
    Else
        Exit Function
    End If
End Function
Function ElevationFromPt(Pt As Variant, varNormal As Variant) As Double
    'Ax+ By + Cz + d = 0 formula for a plane where d=-oLWP.Elevation
    'ElevationFromPt = Pt(0) * UcsNormal(0) + Pt(1) * UcsNormal(1) + Pt(2) * UcsNormal(2)
    ElevationFromPt = (Pt(0) * varNormal(0)) + (Pt(1) * varNormal(1)) + (Pt(2) * varNormal(2))
End Function

Function PolyVertexCheck(oPline As AcadLWPolyline, Optional j As Integer = -1) As Boolean
    'Checks for duplicate verticies
    'Should be closed.
    'Some Double backs
    Dim cCount As Integer
    Dim Dist As Double
    Dim NewCoordList As New Collection
    Dim i As Integer, k As Integer
    Dim Coord As Variant, PrevCoord As Variant, coord2 As Variant
    Dim Coord3 As Variant, Coord4 As Variant
    Dim SlopeCol As New Collection
    Dim BulgeCol As New Collection
    Dim DeltaX As Double, DeltaY As Double
    Dim StartPt As Variant
    Dim M As Double, OrigY As Double
    Dim Slopes(3) As Double
    Dim intXY As Integer
    Dim Rem1 As Integer, Rem2 As Integer
    Dim intSlope As Integer
    Dim obj(0) As AcadEntity
    Dim ss As AcadSelectionSet
    Dim blnBeginning As Boolean
    Dim blnRemoved As Boolean
    
    cCount = (UBound(oPline.Coordinates) - 1) / 2
    
    NewCoordList.Add (0)
    For i = 1 To cCount
        Coord = oPline.Coordinate(i): PrevCoord = oPline.Coordinate(i - 1)
        'Here we check for two equal verticies. Dont add them if they are equal.
        If Rd(Coord(0), PrevCoord(0)) And Rd(Coord(1), PrevCoord(1)) Then GoTo skip
            
        DeltaX = Coord(0) - PrevCoord(0): DeltaY = Coord(1) - PrevCoord(1)
        Slopes(2) = GetSlope(DeltaX, DeltaY, PrevCoord, M, OrigY)
        Slopes(0) = M: Slopes(1) = OrigY
        Slopes(3) = oPline.GetBulge(i - 1)
        SlopeCol.Add Slopes
        k = i
        NewCoordList.Add (k)
skip:
    Next
       
    cCount = NewCoordList.Count
    Debug.Print cCount
    If cCount = 1 Then 'zero length pline
        Set ss = ThisDrawing.SelectionSets("SS")
        If j > -1 Then
            Set obj(0) = ss(j)
            ss.RemoveItems obj
        End If
        oPline.Delete
        PolyVertexCheck = False
        Exit Function '''''
    End If
BeginCheck:
     If cCount > 2 Then
        If SlopeCol.Count = 2 Then
        'check for unneeded middle point in a straigth line
            If SlopeCol(1)(3)  0 Then GoTo Skip2
            If SlopeCol(2)(3)  0 Then GoTo Skip2
            If Rd(SlopeCol(1)(0), SlopeCol(2)(0)) Then
                If Rd(SlopeCol(1)(1), SlopeCol(2)(1)) Then
                    Coord = oPline.Coordinate(0)
                    coord2 = oPline.Coordinate(1)
                    Coord3 = oPline.Coordinate(2)
                    If EqualPts(Coord, Coord3) Then
                        NewCoordList.Remove cCount
                        GoTo Skip2
                    End If
                    intSlope = SlopeCol(1)(2)
                    If intSlope = 1 Then
                        intXY = 1  'vertical
                    Else
                        intXY = 0
                    End If
                    
                    If Coord(intXY) > coord2(intXY) Then
                        If coord2(intXY) > Coord3(intXY) Then
                            NewCoordList.Remove 2
                        Else
                            If Coord(intXY) > Coord3(intXY) Then
                                NewCoordList.Remove 3
                            Else
                                NewCoordList.Remove 1
                            End If
                        End If
                    Else
                        If Coord(intXY) > Coord3(intXY) Then
                                NewCoordList.Remove 1
                        Else
                            If Coord3(intXY) > coord2(intXY) Then
                                NewCoordList.Remove 2
                            Else
                                NewCoordList.Remove 3
                            End If
                        End If
                    End If
                End If
            End If
        Else
            For i = cCount To 3 Step -1
                'check for unneeded middle point in a straigth line
                If oPline.GetBulge(i - 1)  0 Then GoTo Skipi
                If oPline.GetBulge(i - 2)  0 Then GoTo Skipi
                If Rd(SlopeCol(i - 1)(0), SlopeCol(i - 2)(0)) Then
                    If Rd(SlopeCol(i - 1)(1), SlopeCol(i - 2)(1)) Then
                        Coord = oPline.Coordinate(NewCoordList(i))
                        coord2 = oPline.Coordinate(NewCoordList(i - 1))
                        Coord3 = oPline.Coordinate(NewCoordList(i - 2))
                        If Rd(Coord(0), coord2(0)) Then 'vertical
                            intXY = 1
                        Else
                            intXY = 0
                        End If
         
   
                         If i = cCount Then 'Double back at end
                            If Coord(intXY) > Coord3(intXY) Then
                                If Coord(intXY)  coord2(intXY) Then
                                    NewCoordList.Remove (i)
                                    SlopeCol.Remove i - 1
                                    blnRemoved = True
                                    GoTo Skipi ''''''''''''''''''
                                End If
                            End If
                        End If
                        
                        If i - 3 = 0 Then 'Double back at beginning
                            If Coord(intXY) > coord2(intXY) Then
                                If Coord(intXY) > Coord3(intXY) Then
                                    If Coord3(intXY) > coord2(intXY) Then
                                        NewCoordList.Remove (1)
                                        SlopeCol.Remove 1
                                        blnBeginning = True
                                        blnRemoved = True
                                        GoTo Skipi ''''''''''''''''''
                                    End If
                                End If
                            Else
                                If Coord(intXY)  coord2(intXY) Then
                            If coord2(intXY) > Coord3(intXY) Then
                                NewCoordList.Remove (i - 1)
                                SlopeCol.Remove i - 2
                                blnRemoved = True
                                GoTo Skipi ''''''''''''''''''
                            End If
                        Else
                            If coord2(intXY)  2 Then
                cCount = NewCoordList.Count
                For i = cCount To 4 Step -1
                    If oPline.GetBulge(i - 1)  0 Then GoTo Skip2i
                    If oPline.GetBulge(i - 2)  0 Then GoTo Skip2i
                    If oPline.GetBulge(i - 3)  0 Then GoTo Skip2i
                    If oPline.GetBulge(i - 4)  0 Then GoTo Skip2i
                    'Not checking for arc double backs as they are so rare.
                    intSlope = SlopeCol(i - 1)(2)
                    If Not intSlope = SlopeCol(i - 2)(2) Then GoTo Skip2i
                    If Not intSlope = SlopeCol(i - 3)(2) Then GoTo Skip2i
                    If intSlope = 0 Then intXY = 0  'horiz
                    If intSlope = 1 Then intXY = 1  'vertical
                    If intSlope = 2 Then
                        intXY = 2 ''''''''''''''''''''''2-15
                        If Rd(SlopeCol(i - 1)(0), SlopeCol(i - 2)(0)) Then
                            If Rd(SlopeCol(i - 2)(0), SlopeCol(i - 3)(0)) Then
                                If Rd(SlopeCol(i - 1)(1), SlopeCol(i - 2)(1)) Then
                                    If Rd(SlopeCol(i - 2)(1), SlopeCol(i - 3)(1)) Then
                                        intXY = 0
                                    'Else: GoTo Skip2i ''''''''''''''''''''''''''
                                    End If
                                End If
                            End If
                        End If
                    End If
                    
                    If intXY > 1 Then GoTo Skip2i
                                    
    
                    Coord = oPline.Coordinate(NewCoordList(i - 3))
                    coord2 = oPline.Coordinate(NewCoordList(i - 2))
                    Coord3 = oPline.Coordinate(NewCoordList(i - 1))
                    Coord4 = oPline.Coordinate(NewCoordList(i))
                    If Rd(Coord(0), coord2(0)) Then 'vertical
                        intXY = 1
                    Else
                        intXY = 0
                    End If
                    Rem1 = -1: Rem2 = -1
                    'code for double backs''''''''''''''''''''''''''''''
                    If Coord(intXY)  Coord(intXY) Then
                                    Rem1 = i - 1: Rem2 = i - 2
                                Else
                                    Rem1 = i - 2: Rem2 = i - 3
                                End If
                            End If
                        Else
                            If Coord3(intXY) > Coord(intXY) Then
                                Rem1 = i: Rem2 = i - 1
                            Else
                                Rem1 = i: Rem2 = i - 3
                            End If
                        End If
                    Else
                        If coord2(intXY) > Coord4(intXY) Then
                            If Coord3(intXY) > coord2(intXY) Then
                                If Coord3(intXY)  -1 Then
                        NewCoordList.Remove Rem1
                        SlopeCol.Remove Rem1 - 1
                        i = i - 1
                    End If
                    If Rem2 > -1 Then
                        NewCoordList.Remove Rem2
                        'i = i - 1
                        If Rem2 > 1 Then
                            SlopeCol.Remove Rem2 - 1
                        Else
                            SlopeCol.Remove Rem2
                        End If
                    End If
            
                     
Skip2i:
            Next i
        End If
    End If
 End If
Skip2:
    
    
    
    Dim NewPline As AcadLWPolyline
    Dim Cwidth As Double
    Dim blnNonConstantWidth As Boolean
    
    On Error Resume Next
    Cwidth = oPline.ConstantWidth
    If Err.Description = "Invalid input" Then
        blnNonConstantWidth = True
        Err.Clear
    End If
    On Error GoTo 0
    
    'check for should be closed
    If oPline.Closed = False Then
       Dim X1 As Double, Y1 As Double
       Dim X2 As Double, Y2 As Double
       Dim blnClosed As Boolean
       X1 = oPline.Coordinate(NewCoordList(1))(0)
       Y1 = oPline.Coordinate(NewCoordList(1))(1)
       X2 = oPline.Coordinate(NewCoordList(NewCoordList.Count))(0)
       Y2 = oPline.Coordinate(NewCoordList(NewCoordList.Count))(1)
       If Fuzzed(X1, X2, PolyClosedFudge) Then
           If Fuzzed(Y1, Y2, PolyClosedFudge) Then
               NewCoordList.Remove (NewCoordList.Count)
               blnClosed = True
           End If
       End If
    End If
    If Not NewCoordList.Count - 1 = (UBound(oPline.Coordinates) - 1) / 2 Then
        Dim PtsCount As Integer
        PtsCount = (NewCoordList.Count * 2) - 1
        Dim pts() As Double
        ReDim pts(PtsCount) As Double
        cCount = NewCoordList.Count
        For i = 1 To cCount
            k = (i - 1) * 2
            pts(k) = oPline.Coordinate(NewCoordList(i))(0)
            pts(k + 1) = oPline.Coordinate(NewCoordList(i))(1)
        Next
        
        
        Set NewPline = CurrentSpace.AddLightWeightPolyline(pts)
        If oPline.Closed = True Then
            NewPline.Closed = True
        End If
        With NewPline
            .Color = oPline.Color
            .Elevation = oPline.Elevation
            .Layer = oPline.Layer
            .LineType = oPline.LineType
            .LinetypeGeneration = oPline.LinetypeGeneration
            .LineWeight = oPline.LineWeight
            .Normal = oPline.Normal
            .Thickness = oPline.Thickness
            If Cwidth > 0 Then
                .ConstantWidth = Cwidth
            End If
            On Error GoTo 0
            
        End With
        'For i = 1 To NewCoordList.Count
        For i = 1 To SlopeCol.Count
            k = i - 1
            NewPline.SetBulge k, SlopeCol(i)(3)
            If blnNonConstantWidth Then
                Dim StartWidth As Double, endWidth As Double
                oPline.GetWidth NewCoordList(i), StartWidth, endWidth
                NewPline.SetWidth k, StartWidth, endWidth
            End If
        Next
        
        If j = -1 Then
            oPline.Delete
            Set oPline = NewPline
        Else
            Set ss = ThisDrawing.SelectionSets("SS")
            Set obj(0) = ss(j)
            ss.RemoveItems obj
            oPline.Delete
            Set oPline = NewPline
            If blnClosed = True Then
                oPline.Closed = True
            Else
                Set obj(0) = oPline
                ss.AddItems obj
            End If
        End If
        oPline.Update
    End If
   PolyVertexCheck = True
End Function