(defun C:MPipeAcrossStat ( / LM:GetInters LM:UniqueFuzz :SortPtListByDist ss en y n m l p s txt play ptslay)
(vl-load-com)
;----- Lee Mac ~ 19.01.10 www.theswamp.org (modified)
(defun LM:GetInters (ss / list->3D-point i j obj1 obj2 iLst pts lay1 lay2)
(defun list->3D-point (lst)
(if lst (cons (list (car lst) (cadr lst) (caddr lst))
(list->3D-point (cdddr lst)))))
(setq i (sslength ss))
(while (not (minusp (setq j (1- i)
i (1- i))))
(setq obj1 (vlax-ename->vla-object (ssname ss i))
lay1 (vla-get-layer obj1))
(while (not (minusp (setq j (1- j))))
(setq obj2 (vlax-ename->vla-object (ssname ss j))
iLst (append iLst (setq pts (list->3D-point (vlax-invoke obj1 'IntersectWith obj2 acExtendNone))))
lay2 (if (eq play lay1)
(vla-get-layer obj2)
lay1))
(foreach e pts (setq ptslay (append ptslay (list (list e lay2)))))
))
iLst)
;----- Lee Mac, http://www.lee-mac.com/uniqueduplicate.html
(defun LM:UniqueFuzz (l f)
(if l (cons (car l)
(LM:UniqueFuzz (vl-remove-if (function (lambda ( x ) (equal x (car l) f))) (cdr l))
f))))
;----- BlackBox, http://www.cadtutor.net/forum/showthread.php?61433-Help-Sort-a-list-point-by-distance
(defun :SortPtByDist (ptList en)
(mapcar '(lambda (x / ptList2) (setq ptList2 (append (cdr x) ptList2)))
(vl-sort (mapcar '(lambda (x / pt ptlist2) (setq ptlist2 (append (cons (vlax-curve-getDistAtPoint en (vlax-curve-getClosestPointTo en x T))
x)
ptlist2)))
ptList)
'(lambda (x y) (< (car x) (car y))))))
;---------------------------------------------------------------------------------------------------------------------------
(if (and (princ "\nSelect ALL (poly)lines,")
(setq ss (ssget '((0 . "*LINE,ARC"))))
(not (initget 0))
(setq en (car (entsel "\nSelect a PIPELINE: ")))
(wcmatch (cdr (assoc 0 (entget en))) "*LINE")
(setq play (cdr (assoc 8 (entget en))))
(not (initget 0))
(setq y (cadr (getpoint "\nPick a dimension line: ")))
(setq n 0)
(not (command "_.ZOOM" "_O" en ""))
(not (terpri))
(princ "\nCrossings,Easting,Northing,Elevation,Chainage,Between TP")
)
(foreach e (:SortPtByDist (vl-remove-if-not
'(lambda (pt) (vlax-curve-getDistAtPoint en pt))
(LM:UniqueFuzz (LM:GetInters ss) 0.001))
en)
(setq txt (strcat "TP" (itoa (setq p (fix (vlax-curve-getParamAtPoint en e))))
" - TP"
(itoa (1+ p))
"\\PCS-"
(substr "00" 1 (if (>= 2 (strlen (setq m (itoa (setq n (1+ n))))))
(- 2 (strlen m))
0))
m
"/"
(strcase (setq l (last (assoc e ptslay))))
"\\PCH."
(rtos (setq s (vlax-curve-getDistAtPoint en e)) 2 2)
"m"
))
(entmake (list (cons 0 "LINE")
(cons 10 e)
(cons 11 (list (car e) y 0.))
(cons 8 "TEXT COVER")
(cons 62 210)
(cons 210 '(0. 0. 1.))
))
(entmake (list (cons 0 "MTEXT")
(cons 100 "AcDbEntity")
(cons 100 "AcDbMText")
(cons 8 "TEXT COVER")
(cons 10 (list (car e) y 0.))
(cons 40 2); Text height
(cons 50 (* 0.5 pi))
(cons 1 txt)
(cons 71 4)
(cons 62 1)
(cons 63 2)
(cons 90 1)
))
(princ (strcat "\n"
l ","
(rtos (car e) 2 3) ","
(rtos (cadr e) 2 3) ","
"0" "," ; Elevation. To omit type a semicolon in front of the line, or erase the line.
(rtos s 2 3) ","
"TP" (itoa p) " - TP" (itoa (1+ p))
))
)
(princ "\nWrong selection."))
(terpri)(terpri)
(princ)
)Sir, the lisp in some Polyline does not hold. I think it will be nice intersection rather apparent intersection.
