Miracle Button

Ok, so it started simple...
The interior designers/drafts persons in my office use a manufacturers library for the furniture blocks in their base plans. Everything was working fine for them. The blocks they drug in produced beautiful drawings and everyone was happy. Until our guys in the architecture department started using the baseplans to produce construction documents. Then office standards became an issue, and the beautiful blocks bring in beautiful attributes, on many beautiful non-standard layers and have totally meaningless names.
So as any logical cad manger would, I suggested that the interior decorators might pick their favorite blocks clean them up and make a nice pretty tool palette from a library of their own. After they told me where I could stick that idea, I suggested that they might at the very least remove their attributes, refedit their blocks, and rename them to conform with our company standards. I was then read the riot act by incensed decorators who all have degrees, but find cleaning up blocks to tiresome and complicated to be done on a regular basis. I was at my wits end when my boss stepped in and promised them a miracle button that will preform all of these task for them, and he said I would have it ready for them within a week along with several other bits of a menu that will hopefully ensure that they follow company standards without any effort on their part. So I wrote this program... okay so I stole part of this program from this forum and added on bits an pieces to get the needed results, but it lacks a lot! I need help! I want to minimize the ssget to only one pick. I would also like to take care of the renaming and relayering when the block is rebuilt. I don't want them to have to tinker with it. Also, how do I handle errors... like if they rename the block an already existing block name..


(defun c:delatt (/ what what-name whatever bn tdef te ss i en ed)
(setq ohs (getvar "osmode"))
(setvar "osmode" 0)
;;;GET BLOCK NAME
(while (or (not bn)
(not (tblsearch "BLOCK" bn))
)


(setq what (ssget w))
(setq what-name (ssname what 0))
(setq whatever (entget what-name))
(setq where (cdr (assoc 10 whatever)))
(setq bn (cdr (assoc 2 whatever)))
)
(setq tdef (tblsearch "BLOCK" bn)
te (cdr (assoc -2 tdef))
)



;;;REDEFINE BLOCK
(entmake (list (cons 0 "BLOCK")
(cons 2 bn)
(cons 70 0)
(assoc 10 tdef)
)
)
(while te
(if (/= (cdr (assoc 0 (entget te))) "ATTDEF")
(entmake (entget te))
)
(setq te (entnext te))
)

(entmake '((0 . "ENDBLK")))

;;;CHANGE ALL INSERTS
(setq ss (ssget "X"
(list (cons 0 "INSERT")
(cons 2 bn)
)
)
)
(and ss
(setq i (sslength ss))
(princ (strcat "\nRemoving all ATTRIBs from "
(itoa i)
"
INSERTs...\n" )
)
(while (not (minusp (setq i (1- i))))
(princ (strcat "\r" (itoa i) " INSERTS Remaining...."))
(setq en (ssname ss i)
ed (entget en)

)

(setq ed (subst '(66 . 0) '(66 . 1) ed))
(entmake ed)
(entdel en)
(redraw (entlast))
)
)
(prin1)

;;;RENAME and RELAYER THE BLOCK THE EASY WAY

(setq new-name (getstring "\nEnter Block's New Name: "))
(command "rename" "b" bn new-name)
(command "-refedit" where "ok" "all" "n")
(command "chprop" (ssget w) "" "layer" "0" "")
(command "refclose" "s" "")
(setvar "osmode" ohs)
(princ)

)

 

"... I want to minimize the ssget to only one pick ..."

Use (entsel)

That's one more piece of the puzzle. Just the rest to go.

/M

 

Your posted code is incomplete, but I infer that the variable w (terrible
name, BTW, be descriptive; it costs nothing) is an (ssget) filter for the
block name.

So if you want to force (ssget) to only do a single pick and filter at the
same time, do this:

(ssget "+.:E:S" w)


--
R. Robert Bell


Ok, so it started simple...
The interior designers/drafts persons in my office use a manufacturers
library for the furniture blocks in their base plans. Everything was
working fine for them. The blocks they drug in produced beautiful drawings
and everyone was happy. Until our guys in the architecture department
started using the baseplans to produce construction documents. Then office
standards became an issue, and the beautiful blocks bring in beautiful
attributes, on many beautiful non-standard layers and have totally
meaningless names.
So as any logical cad manger would, I suggested that the interior decorators
might pick their favorite blocks clean them up and make a nice pretty tool
palette from a library of their own. After they told me where I could stick
that idea, I suggested that they might at the very least remove their
attributes, refedit their blocks, and rename them to conform with our
company standards. I was then read the riot act by incensed decorators who
all have degrees, but find cleaning up blocks to tiresome and complicated to
be done on a regular basis. I was at my wits end when my boss stepped in
and promised them a miracle button that will preform all of these task for
them, and he said I would have it ready for them within a week along with
several other bits of a menu that will hopefully ensure that they follow
company standards without any effort on their part. So I wrote this
program... okay so I stole part of this program from this forum and added on
bits an pieces to get the needed results, but it lacks a lot! I need help!
I want to minimize the ssget to only one pick. I would also like to take
care of the renaming and relayering when the block is rebuilt. I don't want
them to have to tinker with it. Also, how do I handle errors... like if
they rename the block an already existing block name..


(defun c:delatt (/ what what-name whatever bn tdef te ss i en ed)
(setq ohs (getvar "osmode"))
(setvar "osmode" 0)
;;;GET BLOCK NAME
(while (or (not bn)
(not (tblsearch "BLOCK" bn))
)


(setq what (ssget w))
(setq what-name (ssname what 0))
(setq whatever (entget what-name))
(setq where (cdr (assoc 10 whatever)))
(setq bn (cdr (assoc 2 whatever)))
)
(setq tdef (tblsearch "BLOCK" bn)
te (cdr (assoc -2 tdef))
)



;;;REDEFINE BLOCK
(entmake (list (cons 0 "BLOCK")
(cons 2 bn)
(cons 70 0)
(assoc 10 tdef)
)
)
(while te
(if (/= (cdr (assoc 0 (entget te))) "ATTDEF")
(entmake (entget te))
)
(setq te (entnext te))
)

(entmake '((0 . "ENDBLK")))

;;;CHANGE ALL INSERTS
(setq ss (ssget "X"
(list (cons 0 "INSERT")
(cons 2 bn)
)
)
)
(and ss
(setq i (sslength ss))
(princ (strcat "\nRemoving all ATTRIBs from "
(itoa i)
"
INSERTs...\n" )
)
(while (not (minusp (setq i (1- i))))
(princ (strcat "\r" (itoa i) " INSERTS Remaining...."))
(setq en (ssname ss i)
ed (entget en)

)

(setq ed (subst '(66 . 0) '(66 . 1) ed))
(entmake ed)
(entdel en)
(redraw (entlast))
)
)
(prin1)

;;;RENAME and RELAYER THE BLOCK THE EASY WAY

(setq new-name (getstring "\nEnter Block's New Name: "))
(command "rename" "b" bn new-name)
(command "-refedit" where "ok" "all" "n")
(command "chprop" (ssget w) "" "layer" "0" "")
(command "refclose" "s" "")
(setvar "osmode" ohs)
(princ)

)

 

You may also find this routine useful.

Code:

 ;FixBlock.lsp  [June 30, 1998]
;
; Copyright 1996 - 1998 ManuSoft
;
; Freeware from:
;   ManuSoft
;   http://www.manusoft.com
;
; Load function, then enter FIXBLOCK to redefine selected blocks
;  so that all entities are on layer '0', color 'BYBLOCK'.
;


(defun C:FixBlock (/ ss cnt idx blkname donelist Grp Update)
(defun Grp (gc el) (cdr (assoc gc el)))
(defun Update (bname / ename elist)
(setq ename (tblobjname "BLOCK" bname))
(if
(and ename (zerop (logand 52 (Grp 70 (entget ename '("*"))))))
(progn
(while ename
(setq elist (entget ename '("*"))
elist (subst '(8 . "0") (assoc 8 elist) elist)
elist (if (assoc 62 elist)
(subst '(62 . 0) (assoc 62 elist) elist)
(append elist '((62 . 0)))))
(entmake elist)
(setq ename (entnext ename)))
(if (/= "ENDBLK" (Grp 0 elist))
(entmake '((0 . "ENDBLK") (8 . "0") (62 . 0))))
'T))
)
(if (> (logand (Grp 70 (tblsearch "layer" "0")) 1) 0)
(princ "\nLayer 0 must be thawed before running FIXBLOCK!\n")
(progn
(if
(progn
(princ "\nPress <Enter> to fix all defined blocks\n")
(setq cnt 0
ss (ssget '((0 . "INSERT")))))
(progn
(setq idx (sslength ss))
(while (>= (setq idx (1- idx)) 0)
(if (not (member (setq blkname (Grp 2 (entget (ssname ss idx)))) donelist))
(progn
(if (Update blkname) (setq cnt (1+ cnt)))
(setq donelist (cons blkname donelist))))))
(while (setq blkname (Grp 2 (tblnext "BLOCK" (not blkname))))
(if (Update blkname) (setq cnt (1+ cnt)))))
(princ (strcat "\n" (itoa cnt) " block" (if (= cnt 1) "" "s") " redefined\n"))))
(princ)
)
;End-of-file

 

I finally got it! I am still concerned about error handling, and as was pointed out earlier the variable names and documentation leaves a lot to be desired.... Tear it apart and give me comments. If it isn't documented well, tell me what that line of code does and I will more than gladly learn. I did mention that I stole part of this code directly from this forum and I'm not exactly sure what it does... I am really new at this and working hard to get better so feed back is golden.

(defun c:delatt (/ ohs what-name whatever
bn tdef te telist telayer newlayer
ss i en ed
)
;bn blockname
;te block entity name
(setq ohs (getvar "osmode")) ;save current osnaps settings
(setvar "osmode" 0) ;set osnaps to off
;;;GET BLOCK NAME
(while (or (not bn)
(not (tblsearch "BLOCK" bn))
) ;end condition

(setq what-name (car (entsel))) ;pick block and get entity name
(setq whatever (entget what-name)) ;get association
(setq bn (cdr (assoc 2 whatever))) ;get block name from association list
) ;end while
(setq tdef (tblsearch "BLOCK" bn)
te (cdr (assoc -2 tdef))
)

;;;REDEFINE BLOCK
(entmake (list (cons 0 "BLOCK")
(cons 2 bn)
(cons 70 0)
(cons 8 "0")
(assoc 10 tdef)
)
)
(while te
(if (/= (cdr (assoc 0 (entget te))) "ATTDEF")
(progn
(setq telist (entget te))
(setq telayer (assoc 8 telist))
(setq newlayer (cons 8 "0"))
(setq telist (subst newlayer telayer telist))
(entmod telist)

(entmake telist)

)
)
(setq te (entnext te))
)

(entmake '((0 . "ENDBLK")))

;;;CHANGE ALL INSERTS
(setq ss (ssget "X"
(list (cons 0 "INSERT")
(cons 2 bn)
)
)
)
(and ss
(setq i (sslength ss))
(princ (strcat "\nRemoving all ATTRIBs from "
(itoa i)
"
INSERTs...\n" )
)
(while (not (minusp (setq i (1- i))))
(princ (strcat "\r" (itoa i) " INSERTS Remaining...."))
(setq en (ssname ss i)
ed (entget en)

)

(setq ed (subst '(66 . 0) '(66 . 1) ed))
(entmake ed)
(entdel en)
(redraw (entlast))
)
)
(prin1)

;;;RENAME and RELAYER THE BLOCK THE EASY WAY

(setq new-name (getstring "\nEnter Block's New Name: "))
;get new block name
(command "rename" "b" bn new-name)
;preform command NEED TO ADD LOOP TO PREVENT PROGRAM FROM CLOSING

;;;Clean up and reset
(command "purge" "blocks" "*" "n" "")
(command "purge" "layers" "*" "n" "")
(setvar "osmode" ohs)
(princ)

)