PEDIT из VBA

'Juerg MENZI
'MENZI ENGINEERING GmbH, Switzerland
'http://www.menziengineering.ch
Public Function JoinPline(FstPol As AcadLWPolyline, NxtPol As AcadLWPolyline) As Boolean
Dim FstPar As Variant
Dim NxtPar As Variant
Dim TmpPnt(0 To 1) As Double
Dim FstSiz As Long
Dim NxtSiz As Long
Dim VtxCnt As Long
Dim FstCnt As Long
Dim NxtCnt As Long
Dim RetVal As Boolean
FstPar = FstPol.Coordinates
NxtPar = NxtPol.Coordinates
FstSiz = UBound(FstPar)
NxtSiz = UBound(NxtPar)
'<-Fst<-Nxt
If Distance(FstPar(0), FstPar(1), NxtPar(NxtSiz - 1), NxtPar(NxtSiz)) < 0.000000000001 Then
ReversePline FstPol
FstPar = FstPol.Coordinates
ReversePline NxtPol
NxtPar = NxtPol.Coordinates
RetVal = True
'Fst->Nxt->
ElseIf Distance(FstPar(FstSiz - 1), FstPar(FstSiz), NxtPar(0), NxtPar(1)) < 0.000000000001 Then
RetVal = True
'Fst-><-Nxt
ElseIf Distance(FstPar(FstSiz - 1), FstPar(FstSiz), NxtPar(NxtSiz - 1), NxtPar(NxtSiz)) < 0.000000000001 Then
ReversePline NxtPol
NxtPar = NxtPol.Coordinates
RetVal = True
'<-FstNxt->
ElseIf Distance(FstPar(0), FstPar(1), NxtPar(0), NxtPar(1)) < 0.000000000001 Then
ReversePline FstPol
FstPar = FstPol.Coordinates
RetVal = True
Else
RetVal = False
End If
If RetVal Then
FstCnt = (FstSiz - 1) / 2
NxtCnt = 0
FstPol.SetBulge FstCnt, NxtPol.GetBulge(NxtCnt)
For VtxCnt = 2 To NxtSiz Step 2
FstCnt = FstCnt + 1
NxtCnt = NxtCnt + 1
TmpPnt(0) = NxtPar(VtxCnt)
TmpPnt(1) = NxtPar(VtxCnt + 1)
FstPol.AddVertex FstCnt, TmpPnt
FstPol.SetBulge FstCnt, NxtPol.GetBulge(NxtCnt)
Next VtxCnt
FstPol.Update
NxtPol.Delete
End If
JoinPline = RetVal
End Function
'-----
Public Function Distance(ByVal FstXco As Double, ByVal FstYco As Double, _
ByVal NxtXco As Double, ByVal NxtYco As Double) As Double
Distance = Sqr((FstXco - NxtXco) ^ 2 + (FstYco - NxtYco) ^ 2)
End Function
'-----
Public Function ReversePline(PolObj As AcadLWPolyline)
Dim NewArr() As Double
Dim BlgArr() As Double
Dim OldArr() As Double
Dim SegCnt As Integer
Dim ArrCnt As Integer
Dim ArrSiz As Integer
OldArr = PolObj.Coordinates
ArrSiz = UBound(OldArr)
SegCnt = (ArrSiz - 1) / 2
ReDim NewArr(0 To ArrSiz)
ReDim BlgArr(0 To SegCnt + 1)
For ArrCnt = SegCnt To 0 Step -1
BlgArr(ArrCnt) = PolObj.GetBulge(SegCnt - ArrCnt) * -1
Next ArrCnt
For ArrCnt = ArrSiz To 0 Step -2
NewArr(ArrSiz - ArrCnt + 1) = OldArr(ArrCnt)
NewArr(ArrSiz - ArrCnt) = OldArr(ArrCnt - 1)
Next ArrCnt
PolObj.Coordinates = NewArr
For ArrCnt = 0 To SegCnt
PolObj.SetBulge ArrCnt, BlgArr(ArrCnt + 1)
Next ArrCnt
PolObj.Update
End Function