(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)
)
HTH。，M、 R。 非常感谢marko_ribar
页:
1
[2]