How to join polylines in VBA

I need to join many polylines (they are connected to each other end to end)
into a single polyline. If doing it manually, "PEdit" command is available
for just that. The problem is there are thousand small polyline segments to
be joined.

I cannot find corresponding method in AcadLWPolyline object to join other
entity (AcadLWPolyline, AcadLine, AcadArc...), equivalent to "PEdit"
command. Any idea?

 

How about using PEDIT --> Multiple and entering a FUZZ factor to jump any
gaps between lines??

--
I support two teams: the Red Sox and whoever beats the Yankees.


|I need to join many polylines (they are connected to each other end to end)
| into a single polyline. If doing it manually, "PEdit" command is available
| for just that. The problem is there are thousand small polyline segments
to
| be joined.
|
| I cannot find corresponding method in AcadLWPolyline object to join other
| entity (AcadLWPolyline, AcadLine, AcadArc...), equivalent to "PEdit"
| command. Any idea?
|
|

 

I am trying to make a VBA routine to do the job. I have several hundreds of
drawings to be processed. I do not want to use SendCommand() to call "PEDIT"
in VBA because of the asynchronous nature of this call.

So far, I did this:

Pseudo code:

Dim go As Boolean
go=True

Do Until Not go
go=False
For Each Found AcadLWPolyline (CurrentPL) in Drawing

Search entire drawing to find Polylines that connect to CurrentPL
end to end (two at most)

If found then
(
Join found Polyline(s) to CurrentPL:
a. Get found Polyline's coordinates;
b. Add vertex to CurrentPL using above coordinates
c. Erase found polylines
)
go=True
Exit For to do another Do loop until all polylines in the
drawing do not have other polyline(s) connected to it end to end.
End If

Next

Loop

This is working fine as I expected, if there are not two many polylines in
drawing. But the drawings I am going to process have several thousands of
polylines (after processing, there may be only a few hundreds polylines
left), this process takes way too long to process (up to 20 minutes for
2000KB drawing full of short polyline segments connected to each other end
to end, on a 1GHz CPU machine).

Hope someone can come up with better idea.

 

Hi Norman,
I you only have to run the PEDIT command and nothing else but open the next drawing after it you shouldn't have a problem.
Regards - Nathan

 

Hi Norman

Maybe this code can help you:

Code:

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

Cheers