[编程交流] 将多段线投影到等高线li

(setq obj1 (vlax-ename->vla-object (car (entsel "\nPick 1st object"))))
(while (setq obj2 (vlax-ename->vla-object (car (entsel "\nPick 2nd object"))))
(setq elv (vla-get-elevation obj2))
(vla-put-elevation obj1 elv)
(setq pt (vlax-invoke obj1 'intersectWith obj2 acExtendNone))
(alert (strcat "X=" (rtos (car pt) 2 2)  "\nY=" (rtos (cadr pt) 2 2) "\nZ=" (rtos elv 2 2)))
)

(defun c:flw23pel-new ;fencelwpoly23dpolyelevations
 ( / *error* bbucs ucsf osm cec ss1 ss2 i lw pl sss ssl sspl e sss1 ssl1 sspl1 ppl1 z1 ppl2 pll par 3dpl lws )
 (vl-load-com)
 (defun *error* ( msg )
   (if ucsf
     (command "_.UCS" "_P")
   )
   (command "_.ZOOM" "_P")
   (foreach e 3dpl
     (if (vlax-erased-p e)
       (entdel e)
     )
   )
   (foreach e lws
     (if (vlax-erased-p e)
       (entdel e)
     )
   )
   (if osm
     (setvar 'osmode osm)
   )
   (if cec
     (setvar 'cecolor cec)
   )
   (if msg
     (prompt msg)
   )
   (princ)
 )
 (defun bbucs ( ss / UCS2WCSMatrix WCS2UCSMatrix n ent minpt maxpt minptlst maxptlst minptbbx minptbby minptbbz minptbb maxptbbx maxptbby maxptbbz maxptbb )
   (vl-load-com)
   ;; Doug C. Broad, Jr.
   ;; can be used with vla-transformby to
   ;; transform objects from the UCS to the WCS
   (defun UCS2WCSMatrix ()
     (vlax-tmatrix
       (append
         (mapcar
          '(lambda (vector origin)
           (append (trans vector 1 0 t) (list origin))
         )
         (list '(1 0 0) '(0 1 0) '(0 0 1))
         (trans '(0 0 0) 0 1)
         )
         (list '(0 0 0 1))
       )
     )
   )
   ;; transform objects from the WCS to the UCS
   (defun WCS2UCSMatrix ()
     (vlax-tmatrix
       (append
         (mapcar
          '(lambda (vector origin)
           (append (trans vector 0 1 t) (list origin))
         )
         (list '(1 0 0) '(0 1 0) '(0 0 1))
         (trans '(0 0 0) 1 0)
         )
         (list '(0 0 0 1))
       )
     )
   )
   (if ss
     (progn
       (repeat (setq n (sslength ss))
         (setq ent (ssname ss (setq n (1- n))))
         (vla-TransformBy (vlax-ename->vla-object ent) (UCS2WCSMatrix))
         (vla-getboundingbox (vlax-ename->vla-object ent) 'minpoint 'maxpoint)
         (vla-TransformBy (vlax-ename->vla-object ent) (WCS2UCSMatrix))
         (setq minpt (vlax-safearray->list minpoint))
         (setq maxpt (vlax-safearray->list maxpoint))
         (setq minptlst (cons minpt minptlst))
         (setq maxptlst (cons maxpt maxptlst))
       )
       (setq minptbbx (caar (vl-sort minptlst '(lambda (a b) (< (car a) (car b))))))
       (setq minptbby (cadar (vl-sort minptlst '(lambda (a b) (< (cadr a) (cadr b))))))
       (setq minptbbz (caddar (vl-sort minptlst '(lambda (a b) (< (caddr a) (caddr b))))))
       (setq maxptbbx (caar (vl-sort maxptlst '(lambda (a b) (> (car a) (car b))))))
       (setq maxptbby (cadar (vl-sort maxptlst '(lambda (a b) (> (cadr a) (cadr b))))))
       (setq maxptbbz (caddar (vl-sort maxptlst '(lambda (a b) (> (caddr a) (caddr b))))))
       (setq minptbb (list minptbbx minptbby minptbbz))
       (setq maxptbb (list maxptbbx maxptbby maxptbbz))
     )
   )
   (list minptbb maxptbb)
 )
 (if (= 0 (getvar 'worlducs))
   (progn
     (command "_.UCS" "_W")
     (command "_.PLAN" "")
     (setq ucsf t)
   )
   (command "_.PLAN" "")
 )
 (setq osm (getvar 'osmode))
 (setvar 'osmode 0)
 (setq cec (getvar 'cecolor))
 (setvar 'cecolor "3")
 (prompt "\nSelect OPEN "STRAIGHT" LWPOLYLINES that lie in plane parallel to WCS - PROJECTION LWPOLYLINES (NOT ELEVATION)...")
 (setq ss1 (ssget "_:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 128) '(-4 . "or>") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
 (while (or
          (not ss1)
          (vl-every '(lambda ( x ) (not (equal (caddar (bbucs (ssadd x))) (caddr (cadr (bbucs (ssadd x)))) 1e-6))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss1))))
        )
   (prompt "\nEmpty sel.set... Please reselect again...")
   (setq ss1 (ssget "_:L" (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(70 . 0) '(70 . 128) '(-4 . "or>") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
 )
 (prompt "\nSelect LWPOLYLINES that lie in plane parallel to WCS - ELEVATION LWPOLYLINES (NOT PROJECTION)...")
 (setq ss2 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
 (while (not ss2)
   (prompt "\nEmpty sel.set... Please reselect again...")
   (setq ss2 (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
 )
 (repeat (setq i (sslength ss1))
   (setq lw (ssname ss1 (setq i (1- i))))
   (setq lws (cons lw lws))
   (entdel lw)
 )
 (foreach lw lws
   (entdel lw)
   (setq pl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget lw))))
   (entdel lw)
   (setq sss (ssget "_F" pl (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
   (setq ssl (ssnamex sss))
   (setq sspl (mapcar 'cadr (apply 'append (mapcar '(lambda ( x ) (vl-remove-if-not 'listp x)) ssl))))
   (entdel lw)
   (setq sspl (vl-sort sspl '(lambda ( a b ) (< (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car a) (cadr a) (cdr (assoc 38 (entget lw)))))) (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car b) (cadr b) (cdr (assoc 38 (entget lw))))))))))
   (entdel lw)
   (setq sss1 (ssget "_F" (list (car pl) (mapcar '+ (car sspl) (mapcar '* (mapcar '- (car pl) (car sspl)) (list 1e+3 1e+3)))) (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
   (if sss1
     (progn
       (setq ssl1 (ssnamex sss1))
       (setq sspl1 (mapcar 'cadr (apply 'append (mapcar '(lambda ( x ) (vl-remove-if-not 'listp x)) ssl1))))
       (setq sspl1 (vl-sort sspl1 '(lambda ( a b ) (< (distance (car pl) a) (distance (car pl) b)))))
       (setq ppl1 (car sspl1))
       (setq ppl1 (mapcar '+ '(0 0) ppl1))
       (if ppl1
         (setq z1 (+ (cdr (assoc 38 (entget (ssname (ssget "_C" ppl1 ppl1) 0)))) (* (- (cdr (assoc 38 (entget (ssname (ssget "_C" (car sspl) (car sspl)) 0)))) (cdr (assoc 38 (entget (ssname (ssget "_C" ppl1 ppl1) 0))))) (/ (distance (car sspl) (car pl)) (distance (car sspl) (mapcar '+ '(0 0) ppl1))))))
         (setq z1 0.0)
       )
       (setq pll (cons (list (caar pl) (cadar pl) z1) pll))
     )
   )
   (foreach p (cdr pl)
     (entdel lw)
     (setq par (vlax-curve-getparamatpoint lw (list (car p) (cadr p) (cdr (assoc 38 (entget lw))))))
     (setq ppl1 (last (vl-remove-if '(lambda ( x ) (minusp (- par (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car x) (cadr x) (cdr (assoc 38 (entget lw))))))))) sspl)))
     (entdel lw)
     (setq ppl1 (mapcar '+ '(0 0) ppl1))
     (if (and ppl1 (not (equal ppl1 (last pl) 1e-6)))
       (progn
         (setq sss1 (ssget "_F" (list ppl1 (mapcar '+ ppl1 (mapcar '* (mapcar '- p ppl1) (list 1e+3 1e+3)))) (list '(0 . "LWPOLYLINE") '(-4 . "<or") '(210 0.0 0.0 1.0) '(210 0.0 0.0 -1.0) '(-4 . "or>"))))
         (setq ssl1 (ssnamex sss1))
         (setq sspl1 (mapcar 'cadr (apply 'append (mapcar '(lambda ( x ) (vl-remove-if-not 'listp x)) ssl1))))
         (setq sspl1 (vl-sort sspl1 '(lambda ( a b ) (< (distance (mapcar '+ '(0 0) ppl1) a) (distance (mapcar '+ '(0 0) ppl1) b)))))
         (setq ppl2 (cadr sspl1))
         (setq ppl2 (mapcar '+ '(0 0) ppl2))
         (if ppl2
           (setq z1 (+ (cdr (assoc 38 (entget (ssname (ssget "_C" ppl1 ppl1) 0)))) (* (- (cdr (assoc 38 (entget (ssname (ssget "_C" ppl2 ppl2) 0)))) (cdr (assoc 38 (entget (ssname (ssget "_C" ppl1 ppl1) 0))))) (/ (distance ppl1 p) (distance (mapcar '+ '(0 0) ppl1) ppl2)))))
           (setq z1 0.0)
         )
         (setq pll (cons (list (car p) (cadr p) z1) pll))
       )
     )
   )
   (entdel lw)
   (setq sspl (vl-sort (append sspl pll) '(lambda ( a b ) (< (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car a) (cadr a) (cdr (assoc 38 (entget lw)))))) (vlax-curve-getparamatpoint lw (vlax-curve-getclosestpointto lw (list (car b) (cadr b) (cdr (assoc 38 (entget lw))))))))))
   (entdel lw)
   (setq pll nil)
   (command "_.3DPOLY")
   (foreach p sspl
     (if (vl-some '(lambda ( x ) (if (vlax-curve-getparamatpoint x (list (car p) (cadr p) (cdr (assoc 38 (entget x))))) (setq e x))) (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss2))))
       (command "_non" (list (car p) (cadr p) (cdr (assoc 38 (entget e)))))
       (command "_non" p)
     )
   )
   (command "")
   (setq 3dpl (cons (entlast) 3dpl))
   (entdel (entlast))
 )
 (*error* nil)
)