Extract a block's contour

[bograd]

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.

[ASMI]

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")
)

[Norts]

that looks mighty impressive

[SLW210]

Looks like a silhouette of Garfield.

[fuccaro]

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] <Displacement>: ....

[bograd]

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 ?

[bograd]

I managed to get it to work.
Thank you very much for the help.

[Cadalist]

that looks like the command curve union in Rhinoceros.

curve boolean tools are very useful.

[bograd]

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 ?

[dusko]

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] <Displacement>: ....

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