Extract a block's contour

Is there any way to extract or trace a blocks contour ?

I want a fast solution so i don't have to draw tha contour manualy.

I attach a image to ilustrate my request.

I use AutoCAD 2002.

This lisp program draw contour of selected objects. Type ECO to run. Written by VVA.

;;; ! *********************************************************
;;; !                  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
;http://www.autocad.ru/cgi-bin/f1/board.cgi?t=30724Ed
;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")
)

that looks mighty impressive

Looks like a silhouette of Garfield.

An other way: draw a rectangle around the block and use BPOLY. Click a point between the block and the rectangle. AutoCAD will create two polylines: the desired one and one other in the top of the rectangle. Delete the two rectangles and move the contour in the desired place:

Command: MOVE

Select objects: l

1 found

Select objects:

Specify base point or [Displacement] : ....

Thank you for your help.It looks exactly what i need.

Anyway, i can't seem to get it to work.

How exactly do i load and run this script ?

I managed to get it to work.

Thank you very much for the help.

that looks like the command curve union in Rhinoceros.

curve boolean tools are very useful.

The script runs fine but i discovered a little glitch.

When i have a block which was scaled up or down (on any direction x, y or z)

the script cannot draw the contour.

In other cases, even though the block is not scaled i have to explode it a few times until the script can draw the contour.

Is there a solution for this ?

An other way: draw a rectangle around the block and use BPOLY. Click a point between the block and the rectangle. AutoCAD will create two polylines: the desired one and one other in the top of the rectangle. Delete the two rectangles and move the contour in the desired place:

Command: MOVE

Select objects: l

1 found

 

Select objects:

 

Specify base point or [Displacement] : ....

cool solution (didn't use BPOLY command till now)!

There is a more advanced tool - TotalBoundary. Look at this:

Direct download from this link.