;;; 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 iNSpT
)
;;; External Contour of Objects .
;;; Author: Copyright© 2006-2008 Vladimir A. Azarko (VVA)
;;; Version: 1.1 Jan. 07,2009 Tanks LE and T.Willey for testing. ( http://www.theswamp.org/index.php?topic=26664.0 )
;;; Contact @ http://www.TheSwamp.org; http://www.dwg.ru
;;;
;;; Idea and the first version: http://www.caduser.ru/cgi-bin/f1/board.cgi?t=30724Ed
;;; Final version: http://www.theswamp.org/index.php?topic=26664.0
;;; Also posted: http://www.cadtutor.net/forum/showthread.php?p=148120&posted=1#post148120
;;; http://www.caduser.ru/cgi-bin/f1/board.cgi?t=32457pO&page=1
;;;
;;; Purpose: To construct a contour of the chosen objects, including blocks.
;;; The contour is under construction by means of command BOUNDARY.
;;; Algorithm of work:
;;; 1. We choose objects for construction of a contour.
;;; 2. We calculate a dimension of the chosen objects
;;; 3. We build a rectangular hardly more than the calculated dimension
;;; 4. We hide all not chosen objects in the constructed rectangular
;;; 5. We cause command BOUNDARY and we specify a point between
;;; a rectangular and the chosen objects.

(defun *error* (msg)
(princ 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)
) ;_ end of and
(vla-erase tmp_blk)
) ;_ end of if
(if osm
(setvar "OSMODE" osm)
) ;_ end of if
(foreach x loc (vla-put-lock x :vlax-true))
) ;_ end of defun
(vl-load-com)
(setvar "CMDECHO" 0)
(setq osm (getvar "OSMODE"))
(if (zerop (getvar "WORLDUCS"))
(progn (vl-cmdf "_.UCS" "") (vl-cmdf "_.Plan" ""))
) ;_ end of if
(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)
) ;_ end of setq
(vla-startundomark adoc)
(if isRus
(princ "\nֲבונטעו מבתוךע הכ ןמסענמוםט ךמםעףנא")
(princ "\nSelect objects for making a contour")
) ;_ end of if
(vlax-for lay lays
(if (= (vla-get-lock lay) :vlax-true)
(progn (vla-put-lock lay :vlax-false)
(setq loc (cons lay loc))
) ;_ end of progn
) ;_ end of if
) ;_ end of vlax-for
(if (setq sel (ssget))
(progn
(setq sel (ssnamex sel))
;;; (setq iNSpT(apply 'mapcar (cons 'min
;;; (mapcar 'cadr (apply 'append (mapcar '(lambda(x)(vl-remove-if-not 'listp x)) sel))))))
(setq iNSpT '(0 0 0))
(setq sel (mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp (mapcar 'cadr sel))
) ;_ end of mapcar
) ;_ end of setq
(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"))
(setq unnamed_block
(vla-add (vla-get-blocks adoc)
(vlax-3d-point inspt)
"*U"
) ;_ end of vla-add
) ;_ end of setq
(foreach x sel
(setq oname (strcase (vla-get-objectname x)))
(cond ((member oname
'("ACDBVIEWPORT"
"ACDBATTRIBUTEDEFINITION"
"ACDBMTEXT"
"ACDBTEXT"
)
) ;_ end of member
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)
) ;_ end of vla-InsertBlock
(setq blk (cons x blk))
)
(t (setq obj (cons x obj)))
) ;_ end of cond
) ;_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))
) ;_ end of progn
) ;_ end of if
(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)))
) ;_ end of vlax-make-safearray
obj
) ;_ end of vlax-safearray-fill
) ;_ end of vlax-make-variant
unnamed_block
) ;_ end of vla-copyobjects
) ;_ end of progn
) ;_ end of if
(setq obj (append obj blk))
(if obj
(progn
(setq tmp_blk (vla-insertblock
csp
(vlax-3d-point inspt)
(vla-get-name unnamed_block)
1.0
1.0
1.0
0.0
) ;_ end of vla-insertblock
) ;_ end of setq
(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)))
) ;_ end of max
DS (* 0.2 DS) ;1/5
DS (max DS 10)
MinPt (mapcar '- MinPt (list DS DS))
MaxPt (mapcar '+ MaxPt (list DS DS))
) ;_ end of setq
(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))
) ;_ end of vl-remove-if
) ;_ end of mapcar
hiden (vl-remove tmp_blk hiden)
) ;_ end of setq
(mapcar '(lambda (x) (vla-put-visible x :vlax-false))
hiden
) ;_ end of mapcar
(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 (entlast))
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'(lambda ()
(vl-cmdf "_-BOUNDARY" (trans pt 0 1) "")
(while (> (getvar "CMDACTIVE") 0) (command ""))
) ;_ end of lambda
) ;_ end of VL-CATCH-ALL-APPLY
) ;_ end of VL-CATCH-ALL-ERROR-P
(if isRus
(princ "\nֽו ףהאכמס ןמסענמטע ךמםעףנ")
(princ "\nIt was not possible to construct a contour")
) ;_ end of if
) ;_ end of if
(setq ec sc)
(while (setq ec (entnext ec))
(setq ret (cons (vlax-ename->vla-object ec) ret))
)
(setq ret (vl-remove pl ret))
(mapcar '(lambda (x) (vla-erase x) (vlax-release-object x))
(list pl tmp_blk)
) ;_ end of mapcar
(setq pl nil
tmp_blk nil
) ;_ end of setq
(setq
ret (mapcar '(lambda (x / mipt)
(vla-getboundingbox x 'MiPt nil) ;_ֳנאםטצ בכמךא
(setq MiPt (vlax-safearray->list MiPt))
(list MiPt x)
) ;_ end of lambda
ret
) ;_ end of mapcar
) ;_ end of setq
(setq ret (vl-sort ret
'(lambda (e1 e2)
(< (distance MinPt (car e1))
(distance MinPt (car e2))
) ;_ end of <
) ;_ end of lambda
) ;_ end of vl-sort
) ;_ end of setq
(setq pl (nth 1 ret)
ret (vl-remove pl ret)
) ;_ end of setq
(mapcar 'vla-erase (mapcar 'cadr ret))
(mapcar '(lambda (x) (vla-put-visible x :vlax-true))
hiden
) ;_ end of mapcar
(foreach x loc (vla-put-lock x :vlax-true))
(if pl
(progn
(initget "Yes No")
(if
(= (getkword (if isRus
"\n׃האכע מבתוךע? [Yes/No] : "
"\nDelete objects? [Yes/No] : "
) ;_ end of if
) ;_ end of getkword
"Yes"
) ;_ end of =
(mapcar '(lambda (x)
(if (vlax-write-enabled-p x)
(vla-erase x)
) ;_ end of if
) ;_ end of lambda
obj
) ;_ end of mapcar
) ;_ end of if
) ;_ end of progn
(if isRus
(princ "\nֽו ףהאכמס ןמסענמטע ךמםעףנ")
(princ "\nIt was not possible to construct a contour")
) ;_ end of if
) ;_ end of if
) ;_ end of progn
) ;_ end of if
) ;_ end of progn
) ;_ end of if
(vl-catch-all-apply
'(lambda ()
(mapcar 'vlax-release-object
(list unnamed_block tmp_blk csp blks lays)
) ;_ end of mapcar
) ;_ end of lambda
) ;_ end of VL-CATCH-ALL-APPLY
) ;_ end of progn
) ;_if not
(foreach x loc (vla-put-lock x :vlax-true))
(setvar "OSMODE" osm)
(vla-endundomark adoc)
(vlax-release-object adoc)
(princ)
) ;_ end of defun
;;; ========== HELPER FUNCTION ==========================================
(defun lib:IsPtInView (pt / VCTR Y_Len SSZ X_Pix Y_Pix X_Len Lc Uc)
;| ! *******************************************************************
;; ! lib:IsPtInView
;; ! *******************************************************************
;; ! ֿנמגונוע םאץמהטעס כט עמקךא ג גטהמגמל ‎ךנאםו
;; ! Auguments: 'pt' - ׂמקךא הכ אםאכטחא ג ֺּׁ!!!
;; ! Return : T טכט nil וסכט 'pt' ג גטהמגמל ‎ךנאםו טכט םוע
;; ! *******************************************************************|;
(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))
) ;_ end of setq
(if (and (> (car pt) (car Lc))
( (cadr pt) (cadr Lc))
(< (cadr pt) (cadr Uc))
) ;_ end of and
t
nil
) ;_ end of if
) ;_ end of defun

(defun DTR (a) (* pi (/ a 180.0)))

(defun lib:pt_extents (vlist / tmp)
;| ! ***************************************************************************
;; ! lib:pt_extents
;; ! ***************************************************************************
;; ! Function : ֲמחגנאשאוע דנאםטצ MIN, MAX X,Y,Z סןטסךא עמקוך
;; ! Argument : 'vlist' - ׁןטסמך עמקוך
;; ! Returns : ׁןטסמך עמקוך (ֻוגֽטזם ֿנאגֲונץם)
;; ! ***************************************************************************|;

(setq
tmp (mapcar
'(lambda (x) (vl-remove-if 'null x))
(mapcar
'(lambda (what) (mapcar '(lambda (x) (nth what x)) vlist))
'(0 1 2)
) ;_ end of mapcar
) ;_ end of mapcar
) ;_setq

(list (mapcar '(lambda (x) (apply 'min x)) tmp)
(mapcar '(lambda (x) (apply 'max x)) tmp)
) ;_ end of list
) ;_defun

(defun lib:Zoom2Lst (vlist / bl tr Lst OS)
; ! ***********************************************************
;; ! lib:Zoom2Lst
;; ! **********************************************************
;; ! Function : Zoom דנאםטצ סןטסךא עמקוך
;; ! Arguments: 'vlist' - ׁןטסמך עמקוך ג ֺּׁ!!!!
;; ! ַףללטנףוע ‎ךנאם, קעמב גסו עמקךט בכט גטהם
;; ! Returns : t - בכמ חףללטנמגאםטו nil - םוע
;; ! **********************************************************

(setq Lst (lib:pt_extents vlist)
bl (car Lst)
tr (cadr Lst)
) ;_ end of setq
(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"
) ;_ end of command
(setvar "OSMODE" OS)
t
) ;_ end of progn
NIL
) ;_ end of if
) ;_ end of defun

Advertisements