Try this one
Code:
Function Is2DPointsEqual(p1 As Variant, p2 As Variant, gap As Double) As Boolean
Is2DPointsEqual = False
Dim a, b
a = Abs(CDbl(p1(0)) - CDbl(p2(0)))
b = Abs(CDbl(p1(1)) - CDbl(p2(1)))
If a <= gap And b <= gap Then Is2DPointsEqual = True
End Function
Sub JoinLines()
' based on idea by Norman Yuan
' Fatty T.O.H. () 2007 * all rights removed
' edited 02.04.2008
Dim oSsets As AcadSelectionSets
Dim pSset As AcadSelectionSet
Dim oSset As AcadSelectionSet
Dim setName As String
Dim fType(0) As Integer
Dim fData(0) As Variant
Dim varPt As Variant
Dim pickPt As Variant
Dim fLine As AcadLine
Dim oLine As AcadEntity
Dim oEnt As AcadEntity
Dim commStr As String
Dim stPt(1) As Double
Dim endPt(1) As Double
Dim dxftype, dxfcode
Dim n As Integer
Dim sp As Variant
Dim ep As Variant
Dim ps(1) As Double
Dim pe(1) As Double
Dim vexs As Variant
Dim oSpace As AcadBlock
With ThisDrawing
If .ActiveSpace = acModelSpace Then
Set oSpace = .ModelSpace
Else
Set oSpace = .PaperSpace
End If
End With
On Error GoTo Error_Trapp
Dim osm
osm = ThisDrawing.GetVariable("OSMODE")
ThisDrawing.SetVariable "OSMODE", 1
ThisDrawing.SetVariable "PICKBOX", 1
pickPt = ThisDrawing.Utility.GetPoint(, vbCr & "Select the starting point of the chain of lines :")
ZoomExtents
Set oSsets = ThisDrawing.SelectionSets
fType(0) = 0: fData(0) = "LINE"
dxftype = fType: dxfcode = fData
setName = "FirstLine"
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With
setName = "LineSset"
Set pSset = oSsets.Add("FirstLine")
pSset.SelectAtPoint pickPt, dxftype, dxfcode
If pSset.Count > 1 Then
MsgBox "More than one line selected" & vbCr & _
"Error"
Exit Sub
ElseIf pSset.Count = 1 Then
Set fLine = pSset.Item(0)
ElseIf pSset.Count = 0 Then
MsgBox "Nothing selected" & vbCr & _
"Error"
Exit Sub
End If
sp = fLine.StartPoint
ep = fLine.EndPoint
ps(0) = sp(0): ps(1) = sp(1)
pe(0) = ep(0): pe(1) = ep(1)
If Is2DPointsEqual(pickPt, ps, 0.01) Then
stPt(0) = ps(0): stPt(1) = ps(1)
endPt(0) = pe(0): endPt(1) = pe(1)
ElseIf Is2DPointsEqual(pickPt, pe, 0.01) Then
stPt(0) = pe(0): stPt(1) = pe(1)
endPt(0) = ps(0): endPt(1) = ps(1)
End If
Dim oPline As AcadLWPolyline
Dim coors(3) As Double
coors(0) = stPt(0): coors(1) = stPt(1)
coors(2) = endPt(0): coors(3) = endPt(1)
Set oPline = oSpace.AddLightWeightPolyline(coors)
pSset.Delete
Set pSset = Nothing
Set oSset = oSsets.Add("LineSset")
Dim remLine(0) As AcadEntity
Set remLine(0) = fLine
oSset.Select acSelectionSetAll, , , dxftype, dxfcode
oSset.RemoveItems remLine
fLine.Delete
Dim i As Long
i = 1
Dim Pokey As Boolean
Pokey = True
Do Until Not Pokey
Pokey = False
Gumby:
For n = oSset.Count - 1 To 0 Step -1
Set oLine = oSset.Item(n)
sp = oLine.StartPoint
ep = oLine.EndPoint
ps(0) = sp(0): ps(1) = sp(1)
pe(0) = ep(0): pe(1) = ep(1)
If Is2DPointsEqual(ps, endPt, 0.01) Then
i = i + 1
oPline.AddVertex i, pe
Set remLine(0) = oLine
oSset.RemoveItems remLine
oLine.Delete
vexs = oPline.Coordinate(i)
endPt(0) = vexs(0): endPt(1) = vexs(1)
Pokey = True
Exit For
ElseIf Is2DPointsEqual(pe, endPt, 0.01) Then
i = i + 1
oPline.AddVertex i, ps
Set remLine(0) = oLine
oSset.RemoveItems remLine
oLine.Delete
vexs = oPline.Coordinate(i)
endPt(0) = vexs(0): endPt(1) = vexs(1)
Pokey = True
Exit For
End If
Next n
If oSset.Count > 0 Then
GoTo Gumby
Else
Exit Do
End If
Loop
oSset.Delete
Set oSset = Nothing
Error_Trapp:
ZoomPrevious
If Err.Number <> 0 Then
MsgBox "Error number: " & Err.Number & vbCr & Err.Description
End If
On Error Resume Next
ThisDrawing.SetVariable "OSMODE", osm
ThisDrawing.SetVariable "PICKBOX", 4 '<--change size to your suit
End Sub
~'J'~