Squeeze Block ATT.

[Colby]

The following Lisp routine will change the width factor on a block attribute

I take no credit for this code nor do I remeber where I found it but it works good for me!!!!! :lol:


;squatt.lsp
; routine to squeeze attribute width factors....
; select attribute by pointing, then use the '+' or '-' keys to adjust
; the width factor by 5% increments. You must then hit "enter" (on the
; keyboard) to continue. Each incremental adjustment forces a
; regeneration of the block containing the attribute, causing a
; noticeable delay with large blocks.

(defun aval ( a l / ) (cdr (assoc a l)))

(defun c:squatt ( / hilite pik pikins en found missed el done inp new41 new40)
(setq hilite (getvar "highlight"))
(setvar "highlight" 0)
(while (and (/= (aval 0 (entget (car (setq pik (entsel "Pick attr: ")))))
"INSERT")
(/= (aval 66 (entget (car pik))) 1)))
(setq pikins (osnap (cadr pik) "insert")
en (car pik)
found nil
missed nil)
(if debug (progn (print (entget en)) (command "id" pikins)))
(while (and (not found) (not missed))
(setq el (entget (setq en (entnext en))))
(if debug (print el))
(cond ((= (aval 0 el) "SEQEND")
(setq missed t)
(write-line "\nMissed..."))
((equal (aval (if (or (= (aval 72 el) 5) (= (aval 72 el)
(if (aval 74 el) (aval 74 el) 0)
0))
10 11) el)
pikins 0.00001)
(setq found t)
(write-line "\nFound...."))
(t 'ok)))
(if found
(progn (write-line "Use '+', '-', 'h' or '*' keys, or RETURN when done")
(setq done nil)
(while (not done)
(princ (strcat ""
(rtos (aval 41 el) 2 2) " "))
(while (/= (car (setq inp (grread))) 2))
(cond ((= (cadr inp) 43)
(entmod (subst (cons 41 (+ 0.05 (aval 41 el)))
(assoc 41 el) el))
(setq el (entget en))
(entupd en))
((= (cadr inp) 45)
(entmod (subst (cons 41 (- (aval 41 el) 0.05))
(assoc 41 el) el))
(setq el (entget en))
(entupd en))
((= (cadr inp) 42)
(setq new41 (getreal "New width: "))
(entmod (subst (cons 41 new41)
(assoc 41 el) el))
(setq el (entget en))
(entupd en))
((member (cadr inp) '(72 104))
(setq new40 (getreal "New height: "))
(entmod (subst (cons 40 new40)
(assoc 40 el) el))
(setq el (entget en))
(entupd en))
((= (cadr inp) 13) (setq done t))
(t))))
(prompt "Not found.."))
(setvar "highlight" hilite)
(princ))