AutoLISP: External Contours of Objects

This routine is helpful if you have overlapping objects that form a closed area and you would like to combine them into one overall closed object. This is like the UNION command but for 2D closed areas.

Here’s how:

  • ECO <enter> External Contour of Objects
  • Select overlapping objects <enter>

;| ! *******************************************************************
;; !                  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)))
;| ! ***************************************************************************
;; !           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
;;;(defun GetBoundingBox-3d (pt_lst)
;;;  (list (apply 'mapcar (cons 'min pt_lst))
;;; (apply 'mapcar (cons 'max pt_lst))
;;;  )
; ! ***********************************************************
;; !                             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))
;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)
(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) )
(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"))
  (vlax-for lay lays
      (if (= (vla-get-lock lay) :vlax-true)
          (progn (vla-put-lock lay :vlax-false) (setq loc (cons lay loc))))
 (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))))
    (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"))
    (foreach x sel
      (setq oname (strcase (vla-get-objectname x)))
     ((= 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))
              (setq tmp_blk (vla-insertblock csp (vlax-3d-point inspt)(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))

About AutoCAD Tips

This blog serves as a knowledge base for myself (and anyone else) so that I can reference tips & tricks that I have learned and also refer others to it as well. I hope that this blog helps you learn at least one tip to make your drafting/design experience better.
This entry was posted in AutoLISP, AutoLISP: Creating, AutoLISP: Modify, AutoLISP: Polylines. Bookmark the permalink.

3 Responses to AutoLISP: External Contours of Objects

  1. Daniel says:

    I really would love that routine, but unfortunately I get: “Fehler: Fehlerhafter Argumenttyp: 2D-/3D-Punkt: nil” (sorry, German version, means about ‘wrong argumenttyp:2D-/3D-point: nil’) after loading and after selecting objects I get ‘no function definition: LIB:ZOOM2LST’
    My knowledes in lisp are rather limited … Could someone give an hand, please?
    Thanks, Daniel

  2. PattiM says:

    This is a great routine but is there a way to have the contour be created around two or more “groups” objects at the same time?

Leave a Reply

Fill in your details below or click an icon to log in: Logo

You are commenting using your account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s