AutoCAD Architecture Customization
Welcome to Autodesk’s AutoCAD Architecture Customization Forums. Share your knowledge, ask questions, and explore popular AutoCAD Architecture Customization topics.
cancel
Showing results for 
Show  only  | Search instead for 
Did you mean: 

Lisp routine: snap objects (or walls) to nearest "SNAPUNIT"

5 REPLIES 5
Reply
Message 1 of 6
Anonymous
2279 Views, 5 Replies

Lisp routine: snap objects (or walls) to nearest "SNAPUNIT"

I needed a routine to clean up some walls which weren't drawn accurately. I
prefer to draw all walls to a SNAP unit, like 1" or 1/2". I used this
routine to clean up some walls that we not draw accurately - somebody set
the OTRACK polar angle settings "Increment angle" to "30.00000003". That
really messes up a drawing... Nothing was orthagonal to the original
drawing...

;; Reply From: bruno.valsecchi
;; Date: Nov/09/06 - 13:15 (GMT)
;; modified 2007-08-23 by Craig Vaughn to include ADT "AEC_WALL" objects


(defun round_number (xr n /)
(* (fix (atof (rtos (* xr n) 2 0))) (/ 1.0 n))
)

(defun c:ObjectSnapCleanup (/ js n_count ent dxf_ent dxf_lst ACAD
MODELSPACE P P1 P2 P1-ORIG
P2-ORIG THISDRAWING WALLOBJ X Z)
(setq js
(ssget
'((0
.
"AEC_WALL,FACE3D,ARC,ATTDEF,ATTRIB,CIRCLE,ELLIPSE,INSERT,LINE,POLYLINE,LWPOLYLINE,*TEXT,
POINT,SHAPE,SOLID,TRACE")))
n_count -1)
(cond
(js

(setvar "cmdecho" 0)
(setq acad (vlax-get-acad-object)
thisDrawing (vlax-get acad "activedocument")
modelspace (vlax-get thisDrawing "modelspace")
)
(command "_.undo" "_group")
(while (setq ent (ssname js (setq n_count (1+ n_count))))
(setq dxf_ent (entget ent))
(cond
((eq (cdr (assoc 0 dxf_ent)) "LWPOLYLINE")
(setq dxf_lst (cdr dxf_ent)
dxf_ent (list (car dxf_ent)))
(while (cdr dxf_lst)
(if (eq 10 (caar dxf_lst))
(setq dxf_ent
(cons (cons 10
(mapcar '(lambda (x p) (round_number x (/ 1 p)))
(cdar dxf_lst)
(getvar "SNAPUNIT")))
dxf_ent))
(setq dxf_ent (cons (car dxf_lst) dxf_ent))
)
(setq dxf_lst (cdr dxf_lst))
)
(setq dxf_ent (reverse dxf_ent))
)
((eq (cdr (assoc 0 dxf_ent)) "POLYLINE")
(while (eq (cdr (assoc 0 (setq dxf_ent (entget (entnext (cdar
dxf_ent))))))
"VERTEX")
(setq dxf_ent
(subst (cons 10
(mapcar '(lambda (x p) (round_number x (/ 1 p)))
(cdr (assoc 10 dxf_ent))
(append (getvar "SNAPUNIT")
(list (car (getvar "SNAPUNIT"))))))
(assoc 10 dxf_ent)
dxf_ent))
(entmod dxf_ent)
)
)

((eq (cdr (assoc 0 dxf_ent)) "AEC_WALL")
(setq wallobj (vlax-ename->vla-object ent))
(setq


p1 (vlax-get wallobj 'StartPoint)
p2 (vlax-get wallobj 'EndPoint)
)

(if p1
(progn
(setq p1 (lisp-value p1)
p1-orig p1
z (cddr p1))

(setq p1 (mapcar '(lambda (x p) (round_number x (/ 1 p)))
p1
(getvar "SNAPUNIT")))
(setq p1 (append p1 z))

)
)
(if p2
(progn
(setq p2 (lisp-value p2)
p2-orig p2
z (cddr p2))
(setq p2 (mapcar '(lambda (x p) (round_number x (/ 1 p)))
p2
(getvar "SNAPUNIT")))
(setq p2 (append p2 z))
)

)

(vlax-put wallobj 'startpoint p1)
(vlax-put wallobj 'endpoint p2)
(setq dxf_ent nil)
)
(T
(foreach
n
dxf_ent
(if (member (car n) '(10 11 12 13 40))
(if (listp (cdr n))
(setq dxf_ent
(subst
(cons (car n)
(mapcar '(lambda (x p) (round_number x (/ 1 p)))
(cdr n)
(append (getvar "SNAPUNIT")
(list (car (getvar "SNAPUNIT"))))))
(assoc (car n) dxf_ent)
dxf_ent))
(setq dxf_ent
(subst
(cons (car n)
(round_number (cdr n) (/ 1 (car (getvar "SNAPUNIT")))))
(assoc (car n) dxf_ent)
dxf_ent))
)
)
)
)
)
(if dxf_ent
(progn (entmod dxf_ent) (entupd ent)))
)
(command "_.undo" "_end")
(setvar "cmdecho" 1)
(princ (strcat "\n" (itoa n_count) " transformed objects (s)."))
)
(T (princ "\nNo found valid object ."))
)
(prin1)
)

(defun lisp-value (v) ; the Holy Graal of vla->lisp conversion? 😉
;; Copyright 2002 Vladimir Nesterovsky.
;; Free for use by any commercial entity with
;; less then $100 million annual revenue.
(cond
((= (type v) 'variant)
(lisp-value (variant-value v)))
((= (type v) 'safearray)
(mapcar 'lisp-value (safearray-value v)))
(T v)
)
)

;;Frank Oquendo acadx.dwg
(defun listToVariantArray (lst varType)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
varType
(cons 0 (1- (length lst)))
)
(mapcar
'(lambda (x)
(cond
((= (type x) 'list)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type x))
(cond
((= (type (car x)) 'REAL) vlax-vbDouble)
((= (type (car x)) 'INT) vlax-vbInteger)
((= (type (car x)) 'STR) vlax-vbString)
)
vlax-vbVariant
)
(cons 0 (1- (length x)))
)
x
)
)
((= (type x) 'ename)
(vla-get-objectid (vlax-ename->vla-object x))
)
(t x)
)
)
lst
)
)
)
)
5 REPLIES 5
Message 2 of 6
Anonymous
in reply to: Anonymous

Craig: In your workplace I would think BOTH ends of a line need to be
snapped. I think I see an account for only the starting point, but not the
ending point. (assoc 11 dxf_ent) ?


--
_________________________

Bill DeShawn
bdeshawn@nospamsterling.net
http://my.sterling.net/~bdeshawn


"CraigV (fs)" wrote in message
news:5699580@discussion.autodesk.com...
I needed a routine to clean up some walls which weren't drawn accurately. I
prefer to draw all walls to a SNAP unit, like 1" or 1/2". I used this
routine to clean up some walls that we not draw accurately - somebody set
the OTRACK polar angle settings "Increment angle" to "30.00000003". That
really messes up a drawing... Nothing was orthagonal to the original
drawing...

;; Reply From: bruno.valsecchi
;; Date: Nov/09/06 - 13:15 (GMT)
;; modified 2007-08-23 by Craig Vaughn to include ADT "AEC_WALL" objects


(defun round_number (xr n /)
(* (fix (atof (rtos (* xr n) 2 0))) (/ 1.0 n))
)

(defun c:ObjectSnapCleanup (/ js n_count ent dxf_ent dxf_lst ACAD
MODELSPACE P P1 P2 P1-ORIG
P2-ORIG THISDRAWING WALLOBJ X Z)
(setq js
(ssget
'((0
.
"AEC_WALL,FACE3D,ARC,ATTDEF,ATTRIB,CIRCLE,ELLIPSE,INSERT,LINE,POLYLINE,LWPOLYLINE,*TEXT,
POINT,SHAPE,SOLID,TRACE")))
n_count -1)
(cond
(js

(setvar "cmdecho" 0)
(setq acad (vlax-get-acad-object)
thisDrawing (vlax-get acad "activedocument")
modelspace (vlax-get thisDrawing "modelspace")
)
(command "_.undo" "_group")
(while (setq ent (ssname js (setq n_count (1+ n_count))))
(setq dxf_ent (entget ent))
(cond
((eq (cdr (assoc 0 dxf_ent)) "LWPOLYLINE")
(setq dxf_lst (cdr dxf_ent)
dxf_ent (list (car dxf_ent)))
(while (cdr dxf_lst)
(if (eq 10 (caar dxf_lst))
(setq dxf_ent
(cons (cons 10
(mapcar '(lambda (x p) (round_number x (/ 1 p)))
(cdar dxf_lst)
(getvar "SNAPUNIT")))
dxf_ent))
(setq dxf_ent (cons (car dxf_lst) dxf_ent))
)
(setq dxf_lst (cdr dxf_lst))
)
(setq dxf_ent (reverse dxf_ent))
)
((eq (cdr (assoc 0 dxf_ent)) "POLYLINE")
(while (eq (cdr (assoc 0 (setq dxf_ent (entget (entnext (cdar
dxf_ent))))))
"VERTEX")
(setq dxf_ent
(subst (cons 10
(mapcar '(lambda (x p) (round_number x (/ 1 p)))
(cdr (assoc 10 dxf_ent))
(append (getvar "SNAPUNIT")
(list (car (getvar "SNAPUNIT"))))))
(assoc 10 dxf_ent)
dxf_ent))
(entmod dxf_ent)
)
)

((eq (cdr (assoc 0 dxf_ent)) "AEC_WALL")
(setq wallobj (vlax-ename->vla-object ent))
(setq


p1 (vlax-get wallobj 'StartPoint)
p2 (vlax-get wallobj 'EndPoint)
)

(if p1
(progn
(setq p1 (lisp-value p1)
p1-orig p1
z (cddr p1))

(setq p1 (mapcar '(lambda (x p) (round_number x (/ 1 p)))
p1
(getvar "SNAPUNIT")))
(setq p1 (append p1 z))

)
)
(if p2
(progn
(setq p2 (lisp-value p2)
p2-orig p2
z (cddr p2))
(setq p2 (mapcar '(lambda (x p) (round_number x (/ 1 p)))
p2
(getvar "SNAPUNIT")))
(setq p2 (append p2 z))
)

)

(vlax-put wallobj 'startpoint p1)
(vlax-put wallobj 'endpoint p2)
(setq dxf_ent nil)
)
(T
(foreach
n
dxf_ent
(if (member (car n) '(10 11 12 13 40))
(if (listp (cdr n))
(setq dxf_ent
(subst
(cons (car n)
(mapcar '(lambda (x p) (round_number x (/ 1 p)))
(cdr n)
(append (getvar "SNAPUNIT")
(list (car (getvar "SNAPUNIT"))))))
(assoc (car n) dxf_ent)
dxf_ent))
(setq dxf_ent
(subst
(cons (car n)
(round_number (cdr n) (/ 1 (car (getvar "SNAPUNIT")))))
(assoc (car n) dxf_ent)
dxf_ent))
)
)
)
)
)
(if dxf_ent
(progn (entmod dxf_ent) (entupd ent)))
)
(command "_.undo" "_end")
(setvar "cmdecho" 1)
(princ (strcat "\n" (itoa n_count) " transformed objects (s)."))
)
(T (princ "\nNo found valid object ."))
)
(prin1)
)

(defun lisp-value (v) ; the Holy Graal of vla->lisp conversion? 😉
;; Copyright 2002 Vladimir Nesterovsky.
;; Free for use by any commercial entity with
;; less then $100 million annual revenue.
(cond
((= (type v) 'variant)
(lisp-value (variant-value v)))
((= (type v) 'safearray)
(mapcar 'lisp-value (safearray-value v)))
(T v)
)
)

;;Frank Oquendo acadx.dwg
(defun listToVariantArray (lst varType)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
varType
(cons 0 (1- (length lst)))
)
(mapcar
'(lambda (x)
(cond
((= (type x) 'list)
(vlax-safearray-fill
(vlax-make-safearray
(if (apply '= (mapcar 'type x))
(cond
((= (type (car x)) 'REAL) vlax-vbDouble)
((= (type (car x)) 'INT) vlax-vbInteger)
((= (type (car x)) 'STR) vlax-vbString)
)
vlax-vbVariant
)
(cons 0 (1- (length x)))
)
x
)
)
((= (type x) 'ename)
(vla-get-objectid (vlax-ename->vla-object x))
)
(t x)
)
)
lst
)
)
)
)
Message 3 of 6
pgartung
in reply to: Anonymous

Does this lisp routine work for cleaning up lines, plines, arcs, circles, etc.? If yes, how do I use it? I have a lot of need to do this kind of cleanup in my workplace. Thanks.
Message 4 of 6
Anonymous
in reply to: Anonymous

It is an adapted version from somebody else. I only changed it to work with
AEC walls. It will still work on lines, plines, circles, though. If you
want the original, look for this post (as noted in the file):

;; Reply From: bruno.valsecchi
;; Date: Nov/09/06 - 13:15 (GMT)

wrote in message news:5727771@discussion.autodesk.com...
Does this lisp routine work for cleaning up lines, plines, arcs, circles,
etc.? If yes, how do I use it? I have a lot of need to do this kind of
cleanup in my workplace. Thanks.
Message 5 of 6
Anonymous
in reply to: Anonymous

This lisp is something I have been looking for for a while.
But I have a question. We use a lot of symbols and sometimes users throw them in outside the snap points. This lisp moves them into place, but it doesn't seem to move the text attributes in the block with them.

Is that hard to add in here?
I'm somewhat clueless when it comes to this.
Message 6 of 6
Anonymous
in reply to: Anonymous

On Tue, 8 Apr 2008 08:21:17 +0000, Geironimo <> wrote:

>This lisp is something I have been looking for for a while.
>But I have a question. We use a lot of symbols and sometimes users throw them in outside the snap points. This lisp moves them into place, but it doesn't seem to move the text attributes in the block with them.
>Is that hard to add in here?
>I'm somewhat clueless when it comes to this.

I've seen this exact issue, because I wrote a similar routine to what the OP
posted.

The problem with attributes happens because the LISP routine modifies the
Insertion Point of the Insert entity, which does not automatically move the
attributes along with it.

The proper method to handle this is to (a) test the object to see if it is a
block with attributes, then (b) issue a MOVE command to modify the insert object
to the new IP instead of simply rounding off the IP.

BTW, aside from the acute case of needlessly bloated spaghetti code (and without
comments, a real PIA to fix), a better overall approach would be to simply ask
the user for the precision to round off, rather than rely on the X-value of
SNAPUNIT.

Matt
mstachoni@verizon.net
mstachoni@bhhtait.com

Can't find what you're looking for? Ask the community or share your knowledge.

Post to forums  

Autodesk Design & Make Report

”Boost