Тема: LISP. Отрисовка внешнего контура выбранных объектов
Идея зародилась в теме Контур по блоку
В отличие от последнего кода по ссылке строит полилинию для _boundary не на фиксированном расстоянии, а на 1/5 от максимальной длины или ширины габарита выбранных объектов
;https://www.caduser.ru/forum/topic30797.html ;| ! ******************************************************************* ;; ! lib:IsPtInView ;; ! ******************************************************************* ;; ! Проверяет находится ли точка в видовом экране ;; ! Auguments: 'pt' — Точка для анализа в МСК!!! ;; ! Return : T или nil если 'pt' в видовом экране или нет ;; ! *******************************************************************|; (defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc) (setq pt (trans pt 0 1)) (setq VCTR (getvar "VIEWCTR") Y_Len (getvar "VIEWSIZE") SSZ (getvar "SCREENSIZE") X_Pix (car SSZ) Y_Pix (cadr SSZ) X_Len (* (/ X_Pix Y_Pix) Y_Len) Lc (polar VCTR (dtr 180.0) (* 0.5 X_Len)) Uc (polar Lc 0.0 X_Len) Lc (polar Lc (dtr 270.0) (* 0.5 Y_Len)) Uc (polar Uc (dtr 90.0) (* 0.5 Y_Len))) (if (and (> (car pt) (car Lc))(< (car pt) (car Uc)) (> (cadr pt) (cadr Lc))(< (cadr pt) (cadr Uc))) T nil)) (defun DTR (a)(* pi (/ a 180.0)))(defun RTD (a)(/ (* a 180.0) pi)) ; ! *********************************************************** ;; ! lib:Zoom2Lst ;; ! ********************************************************** ;; ! Function : Zoom границ списка точек ;; ! Arguments: 'vlist' — Список точек в МСК!!!! ;; ! Зуммирует экран, чтобы все точки были видны ;; ! Returns : t — было зуммирование nil — нет ;; ! ********************************************************** (defun lib:Zoom2Lst( vlist / bl tr Lst OS) (setq Lst (lib:pt_extents vlist) bl (car Lst) tr (cadr Lst)) (if (not (and (lib:IsPtInView bl) (lib:IsPtInView tr))) (progn (setq OS (getvar "OSMODE"))(setvar "OSMODE" 0) (command "_.Zoom" "_Window" (trans bl 0 1)(trans tr 0 1) "_.Zoom" "0.95x") (setvar "OSMODE" OS) T) NIL)) ;| ! *************************************************************************** ;; ! lib:pt_extents ;; ! *************************************************************************** ;; ! Function : Возвращает границы MIN, MAX X,Y,Z списка точек ;; ! Argument : 'vlist' — Список точек ;; ! Returns : Список точек (ЛевНижн ПравВерхн) ;; ! ***************************************************************************|; (defun lib:pt_extents (vlist / tmp) (setq tmp (mapcar '(lambda (x) (vl-remove-if 'null x)) (mapcar '(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist)) '(0 1 2))));_setq (list (mapcar '(lambda(x)(apply 'min x)) tmp)(mapcar '(lambda(x)(apply 'max x)) tmp)));_defun ;https://www.caduser.ru/forum/topic30797.html ;External contour of objects (defun C:ECO ( / *error* blk obj MinPt MaxPt hiden pt pl unnamed_block isRus tmp_blk adoc blks lays lay oname sel csp loc sc ec ret DS osm) (defun *error* (msg)(mapcar '(lambda (x) (vla-put-Visible x :vlax-true)) hiden) (vla-endundomark adoc)(if (and tmp_blk (not (vlax-erased-p tmp_blk))(vlax-write-enabled-p tmp_blk) ) (vla-Erase tmp_blk))(if osm (setvar "OSMODE" osm))(foreach x loc (vla-put-lock x :vlax-true))) (vl-load-com)(setvar "CMDECHO" 0)(setq osm (getvar "OSMODE")) (if (zerop (getvar "WORLDUCS"))(progn(vl-cmdf "_.UCS" "")(vl-cmdf "_.Plan" ""))) (setq isRus (= (getvar "SysCodePage") "ANSI_1251")) (setq adoc (vla-get-ActiveDocument (vlax-get-acad-object)) blks (vla-get-blocks adoc) lays (vla-get-layers adoc)) (vla-startundomark adoc)(if isRus (princ "\nВыберите объекты для построения контура")(princ "\nSelect objects for making a contour")) (if (setq sel (ssget))(progn (setq sel (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex sel))))) (setq csp (vla-objectidtoobject adoc (vla-get-ownerid (car sel)))) (setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U")) (foreach x sel (setq oname (strcase (vla-get-objectname x)) lay (vla-item lays (vla-get-layer x))) (if (= (vla-get-lock lay) :vlax-true) (progn (vla-put-lock lay :vlax-false) (setq loc (cons lay loc)))) (cond ((member oname '("ACDBVIEWPORT" "ACDBATTRIBUTEDEFINITION")) nil) ((= oname "ACDBBLOCKREFERENCE") (vla-InsertBlock unnamed_block (vla-get-insertionpoint x)(vla-get-name x) (vla-get-xscalefactor x)(vla-get-yscalefactor x) (vla-get-zscalefactor x)(vla-get-rotation x)) (setq blk (cons x blk))) (t (setq obj (cons x obj)))));_foreach (setq lay (vla-item lays (getvar "CLAYER"))) (if (= (vla-get-lock lay) :vlax-true)(progn (vla-put-lock lay :vlax-false) (setq loc (cons lay loc)))) (if obj (progn (vla-copyobjects (vla-get-activedocument (vlax-get-acad-object)) (vlax-make-variant (vlax-safearray-fill (vlax-make-safearray vlax-vbobject (cons 0 (1- (length obj)))) obj)) unnamed_block))) (setq obj (append obj blk)) (if obj (progn (setq tmp_blk (vla-insertblock csp (vlax-3d-point '(0. 0. 0.))(vla-get-name unnamed_block) 1.0 1.0 1.0 0.0)) (vla-GetBoundingBox tmp_blk 'MinPt 'MaxPt) ;_Границы блока (setq MinPt (vlax-safearray->list MinPt) MaxPt (vlax-safearray->list MaxPt) DS (max (distance MinPt (list (car MinPt)(cadr MaxPt))) (distance MinPt (list (car MaxPt)(cadr MinPt)))) DS (* 0.2 DS) ;1/5 DS (max DS 10) MinPt (mapcar '- MinPt (list DS DS)) MaxPt (mapcar '+ MaxPt (list DS DS))) (lib:Zoom2Lst (list MinPt MaxPt))(setq sset (ssget "_C" MinPt MaxPt)) (if sset (progn (setvar "OSMODE" 0) (setq hiden (mapcar 'vlax-ename->vla-object(vl-remove-if 'listp (mapcar 'cadr (ssnamex sset)))) hiden (vl-remove tmp_blk hiden)) (mapcar '(lambda(x)(vla-put-Visible x :vlax-false)) hiden) (setq pt (mapcar '+ MinPt (list (* 0.5 DS)(* 0.5 DS)))) (vl-cmdf "_.RECTANG" (trans MinPt 0 1)(trans MaxPt 0 1)) (setq pl (vlax-ename->vla-object(entlast))) (setq sc (1-(vla-get-count csp))) (if (VL-CATCH-ALL-ERROR-P (VL-CATCH-ALL-APPLY '(lambda () (vl-cmdf "_-BOUNDARY" (trans pt 0 1) "") (while (> (getvar "CMDACTIVE") 0)(command ""))))) (if isRus (princ "\nНе удалось построить контур")(princ "\nIt was not possible to construct a contour"))) (setq ec (vla-get-count csp)) (while (< sc ec)(setq ret (append ret (list (vla-item csp sc))) sc(1+ sc))) (setq ret (vl-remove pl ret)) (mapcar '(lambda (x)(vla-Erase x)(vlax-release-object x))(list pl tmp_blk))(setq pl nil tmp_blk nil) (setq ret (mapcar '(lambda ( x / mipt)(vla-GetBoundingBox x 'MiPt nil) ;_Границы блока (setq MiPt (vlax-safearray->list MiPt))(list MiPt x)) ret)) (setq ret (vl-sort ret '(lambda (e1 e2)(< (distance MinPt (car e1))(distance MinPt (car e2)))))) (setq pl (nth 1 ret) ret (vl-remove pl ret))(mapcar 'vla-erase (mapcar 'cadr ret)) (mapcar '(lambda(x)(vla-put-Visible x :vlax-true)) hiden) (foreach x loc (vla-put-lock x :vlax-true)) (if pl (progn (initget "Yes No") (if (= (getkword (if isRus "\nУдалять объекты? [Yes/No] <No> : " "\nDelete objects? [Yes/No] <No> : ")) "Yes") (mapcar '(lambda (x) (if (vlax-write-enabled-p x)(vla-Erase x))) obj))) (if isRus (princ "\nНе удалось построить контур")(princ "\nIt was not possible to construct a contour"))))))) (VL-CATCH-ALL-APPLY '(lambda ()(mapcar 'vlax-release-object (list unnamed_block tmp_blk csp blks lays))))));_if not (foreach x loc (vla-put-lock x :vlax-true))(setvar "OSMODE" osm) (vla-endundomark adoc)(vlax-release-object adoc)(princ)) (if (= (getvar "SysCodePage") "ANSI_1251")(princ "\nНаберите в командной строке ECO")(princ "\nType ECO in command line"))