Polylines

Does anyone know of a way to join two polylines from VBA?


Thanks in advance?

 

You have to get/save the vertices of the two existing polylines, find the vertex that they have in common, build a new list of vertices, create a new polyline, and finally, delete to two originals.

 

Not exactly. You should read vertices (coordinates) of adjecent polyline(s)
_adding_ them to the selected (starting) polyline. You may even code in a
"fuzz factor" of very close (but not adjecent) polylines. Then loop through
the selection set of plines being added, deleting them after all vertices
are read/added. In that way all starting pline's properties (including
XData) are preserved, as if you run PLJOIN function.

Regards,
Maksim Sestic
www.geoinova.com

vertex that they have in common, build a new list of vertices, create a new
polyline, and finally, delete to two originals.

 

Hi Rodney

There are 2 ways to join a polyline by vba:
- Use 'Sendcommand'
- Do it by a function (see attachment)

Cheers
--
Juerg Menzi
MENZI ENGINEERING GmbH, Switzerland
http://www.menziengineering.ch
' -----
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

' -----
Function JoinPolyline(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

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
NxtCnt = (NxtSiz - 1) / 2
FstCnt = 0
NxtPol.SetBulge NxtCnt, FstPol.GetBulge(FstCnt)
For VtxCnt = 2 To FstSiz Step 2
FstCnt = FstCnt + 1
NxtCnt = NxtCnt + 1
TmpPnt(0) = FstPar(VtxCnt)
TmpPnt(1) = FstPar(VtxCnt + 1)
NxtPol.AddVertex NxtCnt, TmpPnt
NxtPol.SetBulge NxtCnt, FstPol.GetBulge(FstCnt)
Next VtxCnt
NxtPol.Update
'Fst->Nxt->
ElseIf Distance(FstPar(FstSiz - 1), FstPar(FstSiz), NxtPar(0), NxtPar(1)) < 0.000000000001 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
JoinPolyline = True
'Fst-><-Nxt
ElseIf Distance(FstPar(FstSiz - 1), FstPar(FstSiz), NxtPar(NxtSiz - 1), NxtPar(NxtSiz)) < 0.000000000001 Then
FstCnt = (FstSiz - 1) / 2
NxtCnt = (NxtSiz - 1) / 2
For VtxCnt = NxtSiz To 0 Step -2
FstPol.SetBulge FstCnt, NxtPol.GetBulge(NxtCnt) * -1
FstCnt = FstCnt + 1
NxtCnt = NxtCnt - 1
TmpPnt(0) = NxtPar(VtxCnt - 1)
TmpPnt(1) = NxtPar(VtxCnt)
FstPol.AddVertex FstCnt, TmpPnt
Next VtxCnt
FstPol.Update
JoinPolyline = True
'<-FstNxt-> not available
Else
JoinPolyline = False
End If

End Function

 

Rodney

Forget the sample in my last post. This should work with all possibilities...

Cheers
--
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

 

Thanks for the help!

NxtPar(1)) < 0.000000000001 Then

NxtPar(NxtSiz)) < 0.000000000001 Then

 

Hi Rodney

Glad to help you...

Cheers