Re: Контур по блоку
Выкладываю на тестирование вариант команды, строящий контур по любым выбранным объектам (в пределах возможности BOUNDARY). Выбор блока становится частнам случаем
;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 *MIP-ZOOM-PREV* nil)
(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")
; (setq *MIP-ZOOM-PREV* 2)
(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
;Block Contour
(defun C:BC ( / *error* blk obj MinPt MaxPt hiden pt pl unnamed_block adoc tmp_blk adoc blks lays lay oname sel csp loc)
(defun *error* ( msg )(mapcar '(lambda(x)(vla-put-Visible x :vlax-true)) hiden)
(vla-endundomark adoc)(if (and tmp_blk (vlax-write-enabled-p tmp_blk))(vla-Erase tmp_blk))
(vla-clear sel)(vlax-release-object sel)(foreach x loc (vla-put-lock x :vlax-true)))
(vl-load-com)
(if (zerop (getvar "WORLDUCS"))(progn(vl-cmdf "_.UCS" "")(vl-cmdf "_.Plan" "")))
(setq adoc (vla-get-ActiveDocument (vlax-get-acad-object))
blks (vla-get-blocks adoc)
lays (vla-get-layers adoc)
sel (vla-get-activeselectionset adoc)
)
(vla-startundomark adoc)(vla-clear sel)(princ "\nВыберите объекты для построения контура")
(vla-selectonscreen sel)
(if (not (zerop (vla-get-count sel)))
(progn
(setq csp (vla-objectidtoobject adoc (vla-get-ownerid (vla-item sel 0))))
(setq unnamed_block (vla-add (vla-get-blocks adoc)(vlax-3d-point '(0. 0. 0.)) "*U"))
(vlax-for 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)))
)
);_vlax-for
(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)
MinPt (mapcar '- MinPt '(10 10))
MaxPt (mapcar '+ MaxPt '(10 10)))
(lib:Zoom2Lst (list MinPt MaxPt))
(setq sset (ssget "_C" MinPt MaxPt))
(if sset (progn
(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 '(5 5)))
(vl-cmdf "_.RECTANG" (trans MinPt 0 1)(trans MaxPt 0 1))
(setq pl (vlax-ename->vla-object(entlast)))
(if (VL-CATCH-ALL-ERROR-P (VL-CATCH-ALL-APPLY '(lambda ()
(vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
(while (> (getvar "CMDACTIVE") 0)(command "")))))
(princ "\nНе удалось построить контур"))
(vla-Erase pl)(vla-Erase tmp_blk)(vl-cmdf "_.ERASE" MinPt "")
(setq pl (vlax-ename->vla-object(entlast)))
(mapcar '(lambda(x)(vla-put-Visible x :vlax-true)) hiden)
(initget "Yes No")
(if (= (getkword "\nУдалять объекты? [Yes/No] <No> : ") "Yes")
(mapcar '(lambda (x) (if (vlax-write-enabled-p x) (vla-Erase x))) obj))
)
)
)
)
(vla-clear sel)(vlax-release-object sel)
)
);_if not
(foreach x loc (vla-put-lock x :vlax-true))
(vla-endundomark adoc)(princ))
(princ "\nНаберите в командной строке BC")
