(setq layername
(dos_listbox "LAYERS"
"Please select or enter the layer name of the contours"
(ai_table "LAYER" 4)
)
)
;; Unique - Lee Mac
;; Returns a list with duplicate elements removed.
(defun LM:Unique (l / x r)
(while l
(setq x (car l)
l (vl-remove x (cdr l))
r (cons x r)
)
)
(reverse r)
)
(defun getlayname (/ selset lyrset n ent)
(setq contourstest nil)
(while (= contourstest nil)
(prompt "\nSelect one or more entities to get Contours Layer(s) : ")
(setq selset (ssget "_:L" '((0 . "*LINE")))) ;(setq selset (ssget "_X" (list (cons 0 "*LINE"))))
(setq lyrset (list))
(repeat (setq n (sslength selset))
(setq ent (ssname selset (setq n (1- n))))
(setq lyrset (append lyrset (list (vla-get-layer (vlax-ename->vla-object ent)))))
)
(setq lyrset (LM:Unique lyrset))
(setq contourstest
(ssget "_X"
(append '((0 . "*LINE") (-4 . "<OR")) (mapcar '(lambda (n) (cons 8 n)) lyrset) '((-4 . "OR>")))
)
)
)
)
danglar,
Profile creates ucs a default location. If you are having problems, you can use other Lisp.
The red line looks like the alignment (includes a horizontal curve further 'east')Please, You fix this my-error?
the green line looks like a station label
Select one or more entities to get ContoursLayer/s:
Select objects: Specify opposite corner: 541 found
Select objects:
dfn_getlayname=[((0 . POLYLINE) (8 . Contour))]
; error: bad argument type: safearrayp nil
(defun dfn_listptintersect (ha ha_ename ha_object contourstest imul / $rr dof cnivel_object cnivel_ename curvas)
(setq;|a38908|;
listaxy nil
hazvalue (caddr (vlax-curve-getstartpoint ha_object))
curvas contourstest
ncurvas (sslength curvas)) (setq;|a38996|;
listaxy nil) (progn (setq;|a39014|;
counter 0) (while (< counter ncurvas) (progn (setq;|a39074|;
test nil
interlength rtcan
cnivel_ename (ssname curvas counter)
cnivel_object (vlax-ename->vla-object cnivel_ename)
cnivelzvalue (caddr (vlax-curve-getstartpoint cnivel_object))
ha_entity (subst (cons 38 cnivelzvalue) (assoc 38 (entget (car ha))) (entget (car ha)))) (entmod ha_entity) (setq;|a39310|;
intersectpt (vlax-variant-value (vlax-invoke-method ha_object "intersectwith" cnivel_object acextendnone))) (setq;|a39366|;
test (vl-catch-all-apply (read "vlax-safearray->list") (list intersectpt))) (setq;|a39414|;
error (vl-catch-all-error-p test)) (setq;|a39438|;
intersectpt nil) (if (/= error t) (progn (setq;|a39476|;
intersectpt (vlax-safearray->list intersectpt)
interlength (length intersectpt)))) (if (and (> interlength 3) (/= intersectpt nil)) (progn (setq;|a39572|;
count 0
dividelength (/ interlength 3)) (while (< count interlength) (setq;|a39642|;
newpt (list (nth count intersectpt) (nth (+ count 1) intersectpt) (nth (+ count 2) intersectpt))
x (vlax-curve-getdistatpoint ha_ename newpt)
z (caddr intersectpt)
xy (list x (* z imul))
listaxy (append listaxy (list xy))
count (+ count 3)))) (if (/= intersectpt nil) (setq;|a39930|;
x (vlax-curve-getdistatpoint ha_ename intersectpt)
z (caddr intersectpt)
xy (list x (* z imul))
listaxy (append listaxy (list xy))))) (setq;|a40066|;
ha_entity (subst (cons 38 hazvalue) (assoc 38 (entget (car ha))) (entget (car ha)))) (entmod ha_entity)) (setq;|a40182|;
counter (+ counter 1)))) (setq;|a40204|;
listaxy (vl-sort listaxy (function (lambda (e1 e2) (< (car e1) (car e2)))))) (setq;|a40296|;
startdist (vlax-curve-getdistatpoint ha_ename (vlax-curve-getstartpoint ha_ename))
enddist (vlax-curve-getdistatpoint ha_ename (vlax-curve-getendpoint ha_ename))) (setq;|a40380|;
pt1 (car (car listaxy))
pt2 (car (last listaxy))) (if (/= startdist pt1) (progn (setq;|a40472|;
x startdist
y (+ (* (/ (- (cadr (car listaxy)) (cadr (cadr listaxy))) (- (car (cadr listaxy)) (car (car listaxy)))) (- (car (car listaxy)) startdist)) (cadr (car listaxy)))
xy (list x y)
listaxy (append listaxy (list xy))
listaxy (vl-sort listaxy (function (lambda (e1 e2) (< (car e1) (car e2)))))))) (if (/= enddist pt1) (progn (setq;|a40830|;
pos (- (length listaxy) 1)
x enddist
$rr (nth (- pos 1) listaxy)
dof (nth pos listaxy)
y (+ (* (/ (- (cadr dof) (cadr $rr)) (- (car dof) (car $rr))) (- enddist (car dof))) (cadr dof))
xy (list x y)
listaxy (append listaxy (list xy))
listaxy (vl-sort listaxy (function (lambda (e1 e2) (< (car e1) (car e2))))))))
$rr)