Try this one, assuming this will work with straight segments only,
not treated on your drawing, just I've grab them from my old codes
Option Explicit
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
Public Sub blockPath()
Dim oSset As AcadSelectionSet
Dim pt As Variant
Dim blk1 As AcadBlockReference
Dim blk2 As AcadBlockReference
Dim ent As AcadEntity, ent1 As AcadEntity, ent2 As AcadEntity
Dim ft(0) As Integer
Dim fd(0) As Variant
ft(0) = 0: fd(0) = "lwpolyline"
ThisDrawing.Utility.GetEntity ent1, pt, vbCrLf & "Select First Block:"
If Not TypeOf ent1 Is AcadBlockReference Then
Exit Sub
End If
Set blk1 = ent1
Dim verts1() As Double
verts1 = BoundingBoxTest(ent1)
Dim PointsList1(0 To 11) As Double
Dim cnt, i
cnt = 0
For i = 0 To UBound(verts1, 1)
PointsList1(cnt) = verts1(i, 0)
PointsList1(cnt + 1) = verts1(i, 1)
PointsList1(cnt + 2) = verts1(i, 2)
cnt = cnt + 3
Next
ThisDrawing.Utility.GetEntity ent2, pt, vbCrLf & "Select Second Block:"
If Not TypeOf ent2 Is AcadBlockReference Then
Exit Sub
End If
Set blk2 = ent2
Dim verts2() As Double
verts2 = BoundingBoxTest(ent2)
Dim PointsList2(0 To 11) As Double
cnt = 0
For i = 0 To UBound(verts2, 1)
PointsList2(cnt) = verts2(i, 0)
PointsList2(cnt + 1) = verts2(i, 1)
PointsList2(cnt + 2) = verts2(i, 2)
cnt = cnt + 3
Next
ThisDrawing.Utility.GetEntity ent, pt, vbCrLf & "Select main polyline:"
If Not TypeOf ent Is AcadLWPolyline Then
Exit Sub
End If
Dim mpoly As AcadLWPolyline
Set mpoly = ent
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With
With ThisDrawing.SelectionSets
Set oSset = .Add("$PolySet$")
End With
Dim mode As Integer
mode = acSelectionSetCrossingPolygon
oSset.SelectByPolygon mode, PointsList1, ft, fd
Dim pline1 As AcadLWPolyline
Set ent = oSset.Item(0)
Set pline1 = ent
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
End With
With ThisDrawing.SelectionSets
Set oSset = .Add("$PolySet$")
End With
oSset.SelectByPolygon mode, PointsList2, ft, fd
Dim pline2 As AcadLWPolyline
Set ent = oSset.Item(0)
Set pline2 = ent
Dim intpts1 As Variant
Dim j
intpts1 = pline1.IntersectWith(mpoly, acExtendNone)
Dim inspt1(0 To 2) As Double
If VarType(intpts1) <> vbEmpty Then
For i = LBound(intpts1) To UBound(intpts1)
inspt1(0) = intpts1(j): inspt1(1) = intpts1(j + 1): inspt1(2) = intpts1(j + 2)
i = i + 2
j = j + 3
Next
End If
Dim intpts2 As Variant
intpts2 = pline2.IntersectWith(mpoly, acExtendNone)
j = 0
Dim inspt2(0 To 2) As Double
If VarType(intpts2) <> vbEmpty Then
For i = LBound(intpts2) To UBound(intpts2)
inspt2(0) = intpts2(j): inspt2(1) = intpts2(j + 1): inspt2(2) = intpts2(j + 2)
i = i + 2
j = j + 3
Next
End If
Dim leg As Double
leg = Distance(inspt1, inspt2)
MsgBox "Common Length: " & vbCr & CStr(leg + pline1.Length + pline2.Length)
End Sub
Private Function BoundingBoxTest(oEnt As AcadEntity) As Double()
Dim MaxPoint As Variant
Dim MinPoint As Variant
Dim Vertices(0 To 3, 0 To 2) As Double
oEnt.GetBoundingBox MinPoint, MaxPoint
Vertices(0, 0) = MinPoint(0)
Vertices(0, 1) = MinPoint(1)
Vertices(0, 2) = MinPoint(2)
Vertices(1, 0) = MaxPoint(0)
Vertices(1, 1) = MinPoint(1)
Vertices(1, 2) = MinPoint(2)
Vertices(2, 0) = MaxPoint(0)
Vertices(2, 1) = MaxPoint(1)
Vertices(2, 2) = MinPoint(2)
Vertices(3, 0) = MinPoint(0)
Vertices(3, 1) = MaxPoint(1)
Vertices(3, 2) = MinPoint(2)
BoundingBoxTest = Vertices
End Function
Private Function Distance(fPoint As Variant, sPoint As Variant) As Double
Dim x1 As Double, x2 As Double
Dim y1 As Double, y2 As Double
Dim z1 As Double, z2 As Double
Dim cDist As Double
x1 = sPoint(0): x2 = fPoint(0)
y1 = sPoint(1): y2 = fPoint(1)
z1 = sPoint(2): z2 = fPoint(2)
cDist = Sqr(((x2 - x1) ^ 2) + ((y2 - y1) ^ 2) + ((z2 - z1) ^ 2))
Distance = cDist
End Function
''~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~''
~'J'~