Соединить две полилинии

 
Public Function MeJoinPline(FstPol As AcadLWPolyline, NxtPol As AcadLWPolyline, 
_ 
                            FuzVal as Double) As Boolean 


  Dim FstArr() As Double 
  Dim NxtArr() As Double 
  Dim TmpPnt(0 To 1) As Double 
  Dim FstLen As Long 
  Dim NxtLen As Long 
  Dim VtxCnt As Long 
  Dim FstCnt As Long 
  Dim NxtCnt As Long 
  Dim RevFlg As Boolean 
  Dim RetVal As Boolean 


  With FstPol 
    FstArr = .Coordinates 
    NxtArr = NxtPol.Coordinates 
    FstLen = UBound(FstArr) 
    NxtLen = UBound(NxtArr) 
    '<-Fst<-Nxt 
    If MePointsEqual(FstArr, 1, NxtArr, NxtLen, FuzVal) Then 
      MeReversePline FstPol 
      FstArr = .Coordinates 
      MeReversePline NxtPol 
      NxtArr = NxtPol.Coordinates 
      RevFlg = True 
      RetVal = True 
    '<-FstNxt-> 
    ElseIf MePointsEqual(FstArr, 1, NxtArr, 1, FuzVal) Then 
      MeReversePline FstPol 
      FstArr = .Coordinates 
      RevFlg = True 
      RetVal = True 
    'Fst-><-Nxt 
    ElseIf MePointsEqual(FstArr, FstLen, NxtArr, NxtLen, FuzVal) Then 
      MeReversePline NxtPol 
      NxtArr = NxtPol.Coordinates 
      RevFlg = False 
      RetVal = True 
    'Fst->Nxt-> 
    ElseIf MePointsEqual(FstArr, FstLen, NxtArr, 1, FuzVal) Then 
      RevFlg = False 
      RetVal = True 
    Else 
      RetVal = False 
    End If 


    If RetVal Then 
      FstCnt = (FstLen - 1) / 2 
      NxtCnt = 0 
      .SetBulge FstCnt, NxtPol.GetBulge(NxtCnt) 
      For VtxCnt = 2 To NxtLen Step 2 
        FstCnt = FstCnt + 1 
        NxtCnt = NxtCnt + 1 
        TmpPnt(0) = NxtArr(VtxCnt) 
        TmpPnt(1) = NxtArr(VtxCnt + 1) 
        .AddVertex FstCnt, TmpPnt 
        .SetBulge FstCnt, NxtPol.GetBulge(NxtCnt) 
      Next VtxCnt 
      .Update 
      NxtPol.Delete 
      If RevFlg Then MeReversePline FstPol 
    End If 
  End With 


  MeJoinPline = RetVal 


End Function 


' ----- 
Public Function MeReversePline(PolObj As AcadLWPolyline) 


  Dim NewArr() As Double 
  Dim BlgArr() As Double 
  Dim OldArr() As Double 
  Dim SegCnt As Long 
  Dim ArrCnt As Long 
  Dim ArrLen As Long 


  With PolObj 
    OldArr = .Coordinates 
    ArrLen = UBound(OldArr) 
    SegCnt = (ArrLen - 1) / 2 
    ReDim NewArr(0 To ArrLen) 
    ReDim BlgArr(0 To SegCnt + 1) 


    For ArrCnt = SegCnt To 0 Step -1 
      BlgArr(ArrCnt) = .GetBulge(SegCnt - ArrCnt) * -1 
    Next ArrCnt 
    For ArrCnt = ArrLen To 0 Step -2 
      NewArr(ArrLen - ArrCnt + 1) = OldArr(ArrCnt) 
      NewArr(ArrLen - ArrCnt) = OldArr(ArrCnt - 1) 
    Next ArrCnt 


    .Coordinates = NewArr 
    For ArrCnt = 0 To SegCnt 
      .SetBulge ArrCnt, BlgArr(ArrCnt + 1) 
    Next ArrCnt 
    .Update 
  End With 


End Function 


' ----- 
Public Function MePointsEqual(FstArr, FstPos As Long, NxtArr, NxtPos As Long, _ 
                              FuzVal As Double) As Boolean 


  Dim XcoDst As Double 
  Dim YcoDst As Double 


  XcoDst = FstArr(FstPos - 1) - NxtArr(NxtPos - 1) 
  YcoDst = FstArr(FstPos) - NxtArr(NxtPos) 
  MePointsEqual = (Sqr(XcoDst ^ 2 + YcoDst ^ 2) < FuzVal) 


End Function