Jump to content

Extract a block's contour


bograd

Recommended Posts

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.

Clipboard01.jpg

Link to comment
Share on other sites

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

Cont.gif

Link to comment
Share on other sites

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

Link to comment
Share on other sites

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 ?

Link to comment
Share on other sites

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 ?

Link to comment
Share on other sites

  • 2 years later...
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)!

Link to comment
Share on other sites

  • 4 years later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...