Here is very old lisp I had modified.
;; ***************************************************************
;; pline path finder.lsp
;; CAB 07/08/2004
;; Modified rourine to find a path from picked start entity
;; to picked end entity.
;;
;; Returns the path if it exist else nil
;; Selects & highlites the path also
;; ***************************************************************
;shortcut
(defun c:plp () (c:PlinePath))
;;; ***************************************************************
;;; Original Routine
;;;
;;; ;; based on Inline.lsp by John Uhden
;;; ;; modified Joe Burke 5/15/03
;;; ;; pick a line, arc or lwpline
;;; ;; creates a selection set of objects which meet end to end
;;; ;; only selects objects on the same layer as picked object
;;; ;; pass selection set to pedit join...
;;;
;;; ***************************************************************
;;===================================
;; -=< Sub Routines >=-
;;===================================
;; Return (ename Startpt Endpt)
(defun @arc (ent / e rp r ba ea p1 p2)
(setq e (cdr (assoc -1 ent))
rp (cdr (assoc 10 ent))
r (cdr (assoc 40 ent))
ba (cdr (assoc 50 ent))
ea (cdr (assoc 51 ent))
p1 (trans (polar rp ba r) e 0)
p2 (trans (polar rp ea r) e 0)
)
(list e p1 p2)
) ;end
;; Return (ename Startpt Endpt)
(defun @line (ent)
(list
(cdr (assoc -1 ent))
(cdr (assoc 10 ent))
(cdr (assoc 11 ent))
)
) ;end
;; Return (ename Startpt Endpt)
(defun @pline (ent / e)
(setq e (cdr (assoc -1 ent)))
(list
e
(car (getends e))
(cadr (getends e))
)
) ;end
;; Add ent-> (ename Startpt Endpt) to list
(defun @list (e / ent)
(setq ent (entget e))
(cond
((= (cdr (assoc 0 ent)) "LINE")
(setq sslist (cons (@line ent) sslist))
)
((= (cdr (assoc 0 ent)) "ARC")
(setq sslist (cons (@arc ent) sslist))
)
((= (cdr (assoc 0 ent)) "LWPOLYLINE")
(setq sslist (cons (@pline ent) sslist))
)
)
) ;end
;;argument: an ename - returns: Start and End points as a list
(defun getends (vobj / name stpt endpt)
(if (= (type vobj) 'ename)
(setq vobj (vlax-ename->vla-object vobj))
)
(and
(setq name (vla-get-objectname vobj))
(cond
((vl-position
name
'("AcDbArc" "AcDbLine" "AcDbEllipse"
"AcDbSpline" "AcDbPolyline" "AcDb2dPolyline"
"AcDb3dPolyline"
)
)
(setq stpt (vlax-curve-getstartpoint vobj))
(setq endpt (vlax-curve-getendpoint vobj))
)
) ;cond
) ;and
(list stpt endpt)
) ;end
;; CAB added
;; get list of (ename startpt endpt) for picked ent
(defun get:elst(ent)
(cond
((= (cdr (assoc 0 ent)) "ARC")
(setq ent (@arc ent))
)
((= (cdr (assoc 0 ent)) "LINE")
(setq ent (@line ent))
)
((= (cdr (assoc 0 ent)) "LWPOLYLINE")
(setq ent (@pline ent))
)
)
ent
); end defun
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
;; main function
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
(defun c:plinepath (/ sslist elist ss ssres i e e2
found ent ent2 ok start end start2 end2
fuzz layer ssex typlst
)
;; Get the start object
(if ; vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv
(and
(cadr (ssgetfirst)) ;objects are selected
;;at least one arc, line or pline
(setq ssex (ssget "i" (list (cons 0 "LINE,ARC,LWPOLYLINE"))))
) ;and
;; ====== then =============
(setq e (ssname ssex 0))
;; ====== else =============
(progn
(sssetfirst)
(setq typlst '("LINE" "ARC" "LWPOLYLINE"))
(while
(or
(not (setq e (car (entsel "\nSelect Starting line, pline or arc: "))))
(not (member (cdr (assoc 0 (entget e))) typlst))
)
(princ "\nMissed pick or wrong object type: ")
) ;while
) ;progn
) ;if ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
;; Get the End object, CAB added
(setq typlst '("LINE" "ARC" "LWPOLYLINE"))
(while
(or
(not (setq e2 (car (entsel "\nSelect Ending line, pline or arc: "))))
(not (member (cdr (assoc 0 (entget e2))) typlst))
)
(princ "\nMissed pick or wrong object type: ")
) ;while
(and
(setq ok 1
fuzz 1e-8 ; 0.00000001
)
(setq ent (entget e)) ; first or picked ent
(setq ent2 (entget e2)) ; second picked ent
(setq layer (cdr (assoc 8 ent))) ; layer to match
(= layer (cdr (assoc 8 ent2))) ; layers match
(setq ent (get:elst ent)
elist '()
start (cadr ent)
end (caddr ent)
ent2 (get:elst ent2); CAB
start2 (cadr ent2)
end2 (caddr ent2)
)
(setq ss ; get all objects that matched picked
(ssget "X" (list '(0 . "LINE,ARC,LWPOLYLINE") (cons 8 layer)))
)
(ssdel e ss) ; remove picked start from selection set
;; make a list of all from ss ((ename startpt endpt) ....)
(setq i 0)
(repeat (sslength ss)
(@list (ssname ss i))
(setq i (1+ i))
) ;repeat
;; CAB revised from here down
;; find attached items, does not test all branches
(@ckpoint start ent sslist)
(if (not found) ; check the other end of start ent
(@ckpoint end ent sslist)
)
) ;and
(if found
(progn
(setq elist (cons ent elist))
(setq ssres (ssadd))
(foreach x elist ; create a selection set of the list
(ssadd (car x) ssres)
)
(prompt "\n*-* Done *-*\n")
(cadr(sssetfirst nil ssres)) ; display the selected items
); progn
(prompt "\n*-* Path not found *-*")
)
) ;end
;; -------------------------------
;; @ckPoint by CAB
;; check the list for matching points
;; p point to match
;; elst (ename startpt endpt) of pt
;; |List list pf remaining elst
(defun @ckpoint( p elst |list / entx ex p1 p2 idx res)
(setq idx (length |List))
(while (and (not found) (>= (setq idx (1- idx)) 0))
(setq entx (nth idx |List)
ex (car entx)
p1 (cadr entx)
p2 (caddr entx)
)
(cond ; test point match with fuzz factor
((equal p start2 fuzz) ; text for target
(setq found 1)
(setq elist (cons ent2 elist))
)
((equal p end2 fuzz) ; text for target
(setq found 1)
(setq elist (cons ent2 elist))
)
((equal p p1 fuzz) ; test for next branch
(setq res (@ckpoint p2 entx (vl-remove entx |List)))
(if found ; we are backing out collecting the path
(setq elist (cons entx elist))
)
)
((equal p p2 fuzz) ; test for next branch
(setq res (@ckpoint p1 entx (vl-remove entx |List)))
(if found; we are backing out collecting the path
(setq elist (cons entx elist))
)
)
)
); while
T ; return to satisfy AND
); defun
;;========================
;; End Of File
;;========================
