[编程交流] 3D p纵断面

(defun c:flw23pel ;fencelwpoly23dpolyelevations
 ( / *error* bbucs ucsf osm cec ss1 ss2 i lw pl sss ssl sspl e )
 (vl-load-com)
 (defun *error* ( msg )
   (if ucsf
     (command "_.UCS" "_P")
   )
   (command "_.ZOOM" "_P")
   (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 (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 (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 pl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= (car x) 10)) (entget 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 ssl (vl-remove-if '(lambda ( x ) (eq (cadr x) lw)) ssl))
   (setq sspl (mapcar 'cadr (apply 'append (mapcar '(lambda ( x ) (vl-remove-if-not 'listp x)) ssl))))
   (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))))))))))
   (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 "")
 )
 (*error* nil)
)