Function LineLineIntersect(p1 As POINT3D, p2 As POINT3D, p3 As POINT3D, p4 As POINT3D, pa As POINT3D, pb As POINT3D, Optional distance As Double = 0, Optional mua As Double = 0, Optional mub As Double = 0) As Boolean Dim p13 As POINT3D Dim p43 As POINT3D Dim p21 As POINT3D Dim distances(2) As Double Dim BOUNDARY(2) As POINT3D 'should be renamed to something more meaningful Dim d1343, d4321, d1321, d4343, d2121, numer, denom As Double Dim PTEST As Boolean LineLineIntersect = False p13.x = p1.x - p3.x p13.y = p1.y - p3.y p13.z = p1.z - p3.z p43.x = p4.x - p3.x p43.y = p4.y - p3.y p43.z = p4.z - p3.z If Abs(p43.x) < eps And Abs(p43.y) < eps And Abs(p43.z) < eps Then Exit Function p21.x = p2.x - p1.x p21.y = p2.y - p1.y p21.z = p2.z - p1.z If Abs(p21.x) < eps And Abs(p21.y) < eps And Abs(p21.z) < eps Then Exit Function d1343 = p13.x * p43.x + p13.y * p43.y + p13.z * p43.z d4321 = p43.x * p21.x + p43.y * p21.y + p43.z * p21.z d1321 = p13.x * p21.x + p13.y * p21.y + p13.z * p21.z d4343 = p43.x * p43.x + p43.y * p43.y + p43.z * p43.z d2121 = p21.x * p21.x + p21.y * p21.y + p21.z * p21.z denom = d2121 * d4343 - d4321 * d4321 If (Abs(denom) < eps) Then Exit Function numer = d1343 * d4321 - d1321 * d4343 If denom <> 0 Then mua = numer / denom End If If d4343 <> 0 Then mub = (d1343 + d4321 * (mua)) / d4343 End If pa.x = p1.x + mua * p21.x pa.y = p1.y + mua * p21.y pa.z = p1.z + mua * p21.z pb.x = p3.x + mub * p43.x pb.y = p3.y + mub * p43.y pb.z = p3.z + mub * p43.z distance = Sqr((pb.x - pa.x) ^ 2 + (pb.y - pa.y) ^ 2 + (pb.z - pa.z) ^ 2) LineLineIntersect = True distances(1) = distance 'test if nearest distance is in the "middle" of the 2 segments PTEST = True If PTEST Then Call FindDistanceToSegment(p1, p2, pa, BOUNDARY(1), PTEST) End If If PTEST Then Call FindDistanceToSegment(p3, p4, pb, BOUNDARY(1), PTEST) End If 'distance must be outside so get the nearest distance by the endpoints If Not PTEST Then distances(0) = FindDistanceToSegment(p1, p2, p3, BOUNDARY(0), PTEST) distances(2) = FindDistanceToSegment(p1, p2, p4, BOUNDARY(2), PTEST) If distances(0) <= distances(2) Then pa = p3 pb = BOUNDARY(0) distance = distances(0) Else pa = p4 pb = BOUNDARY(2) distance = distances(2) End If End If 'folowing code can be omitted it just works in acad 'distlimit =16 'chose whatever you need If distance <= distlimit Then Dim polyObj As Acad3DPolyline Dim points(0 To 8) As Double points(0) = pa.x: points(1) = pa.y: points(2) = pa.z points(3) = 0.5 * (pa.x + pb.x): points(4) = 0.5 * (pa.y + pb.y): points(5) = 0.5 * (pa.z + pb.z) points(6) = pb.x: points(7) = pb.y: points(8) = pb.z If round(36 - distance, 0) > 3 Then Set polyObj = ThisDrawing.modelspace.Add3DPoly(points) polyObj.color = acMagenta polyObj.layer = "DELETEME" Dim tpoint(2) As Double Dim mtext As AcadMText tpoint(0) = 0.5 * (pa.x + pb.x) tpoint(1) = 0.5 * (pa.y + pb.y) tpoint(2) = 0.5 * (pa.z + pb.z) Set mtext = ThisDrawing.modelspace.AddMText(tpoint, 0, "") mtext.AttachmentPoint = acAttachmentPointMiddleCenter mtext.layer = "DELETEME" mtext.height = 100 'mtext.BackgroundFill = True mtext.textstring = Fix(str(round(distlimit - distance, 0))) mtext.insertionPoint = tpoint mtext.color = acRed If round(distlimit - distance, 0) < 5 Then mtext.color = acGreen If round(distlimit - distance, 0) > 5 And round(distlimit - distance, 0) <= 10 Then mtext.color = acYellow End If End If End Function