Hi, I am tring to wirte an lisp routin that will purge all purgeable blocks except for two other blocks. The routin I have now will search all blocks in the drawing but cann't seem to found any purgeable blocks can somebody help?
please and thanks!
here is the code :
(defun purgeBlock()
(setq ss (ssget "x" (list (cons 0 "INSERT"))))
(SETQ con1 0)
(repeat (sslength ss)
(SETQ ss2 (ssname ss con1))
(setq ss1 (entget ss2))
(setq ss3 (cdr (assoc 8 ss1)))
(if (AND (/= ss3 "Operator_Logos_WS") (/= ss3 "Operator_Logos_PL"))
(command "-purge" "block" ss3 "n")
)
(setq con1 (+ con1 1))
(XRED)
(princ)
)
)
Hi amyyoyo1,
with (cdr (assoc 8 ss1)) You'll get the Layer name where the block is inserted.
"Operator_Logos_WS" and Operator_Logos_PL are Layer names or block names?
If block names, perhaps something like this
(defun c:test ( / ADOC LST N) (setq aDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-for blk (vla-get-blocks aDoc) (if (and (eq :vlax-false (vla-get-islayout blk)) (eq :vlax-false (vla-get-isxref blk)) (if (vlax-property-available-p blk 'effectivename) (setq n (vla-get-effectivename blk)) (setq n (vla-get-name blk)) ) ) (if (and (not (member n lst)) (not (wcmatch n "Operator_Logos_WS,Operator_Logos_PL")) ) (setq lst (cons n lst)) ) ) ) (if (> (length lst) 0) (foreach blk lst (command "-purge" "block" blk "n") ) ) )
HTH
Henrique
In addition to Henrique's comments: If you can select it then it isn't purgable...
nice approach though... but, instead of using short form code and repeating the purge command for each member of the blk list, how about stretching the code out and creating a string instead which can then be passed to the purge command. then repeat that a couple of times to kill nested blocks as well:
(defun C:purgeBlock ( / aDoc n blkstr) (setq aDoc (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-for blk (vla-get-blocks aDoc) (if (and (eq :vlax-false (vla-get-islayout blk)) (eq :vlax-false (vla-get-isxref blk)) ) (progn (if (vlax-property-available-p blk "effectivename") (setq n (vla-get-effectivename blk)) (setq n (vla-get-name blk)) ) (if (not (vl-member-if '(lambda (Exception) (wcmatch (strcase n) (strcase Exception)) );lambda (list "Operator_Logos_WS" "Operator_Logos_PL") );vl-member-if );if test cond (if blkstr (setq blkstr (strcat blkstr "," n)) (setq blkstr n) ) ) ) ) ) (vlax-release-object aDoc) (repeat 3 (command "-purge" "blocks" blkstr "n") ) )
Just a thought...
To do it the old fashion way, change your line of code as others have already posted which incorrrectly retrieves the Layer Name:
(setq ss3 (cdr (assoc 8 ss1)))
To the correctly line of code which retrieves the block name:
(setq ss3 (cdr (assoc 2 ss1)))
@Anonymous wrote:
... how about stretching the code out and creating a string instead which can then be passed to the purge command. then repeat that a couple of times to kill nested blocks as well
Nicely done!
Henrique
@Anonymous wrote:
Hi, I am tring to wirte an lisp routin that will purge all purgeable blocks except for two other blocks. The routin I have now will search all blocks in the drawing but cann't seem to found any purgeable blocks can somebody help?
....
(defun purgeBlock()
(setq ss (ssget "x" (list (cons 0 "INSERT"))))
....(if (AND (/= ss3 "Operator_Logos_WS") (/= ss3 "Operator_Logos_PL"))
(command "-purge" "block" ss3 "n")
....
That seems to me to be going about it the wrong way. It is finding all insertions of Blocks, and if any is not of the two particular Block names, trying to Purge its Block definition. But it won't be able to Purge the definition of a Block that's inserted in the drawing. It isn't going to find Blocks that are Purge-able, because those won't be inserted anywhere, and so won't be found by that (ssget) function.
I think what you want to do is to step through the Block definition table, and for each name of a Block that's defined, do:
(ssget "X" '((2 . "TheBlockName")))
to see whether there are any of them inserted. If that returns nil, and TheBlockName isn't one of the special ones, then Purge that Block definition.
You'll need to make it a little more sophisticated if you need to account for effective names of dynamic Blocks, and it won't be able to Purge any that are not inserted on their own but are nested in other Block definitions, unless those other Blocks are also unused and Purged first.
Here's another thought:
Just Insert one of each of the two special Blocks, do a Purge of all Blocks regardless, maybe repeat the Purge a few times for nested Blocks, and then delete those two you just inserted. All other unused Block definitions will be purged, but those two will still be available whether or not there were any insertions of them beforehand. No (ssget)-ing, no evaluations of whether names match, nor of whether something is an Xref or other variant on the idea of a Block, no individual Block names or strings of names fed to Purge, no stepping through either a selection set or the Block table, etc.
@Anonymous wrote:
.... Of course there's always the possibility that the requested block has already been purged but....
That possibility can be dealt with, at least to some degree, thus:
(defun C:PABE (/ entl cmde) ; = Purge All Blocks Except
(setq
entl (entlast); starting point for later in removing temporary Blocks
cmde (getvar 'cmdecho)
); setq
(setvar 'cmdecho 0)
(foreach blk '("SpecialBlock1" "SpecialBlock2"); add as many as you like
(if (or (tblsearch "block" blk) (findfile (strcat blk ".dwg")))
; already in drawing or available in Support File Search Paths?
(command "_.insert" blk (getvar 'viewctr) "" "" ""); temporarily
); if
); foreach
(repeat 3 (command "_.purge" "_block" "*" "_no")); or more than 3 if you prefer
(while (setq entl (entnext entl)) (entdel entl)); remove temporary ones
(setvar 'cmdecho cmde)
(princ)
); defun
That will even bring back in any of those special Blocks that's been Purged, as long as it's somewhere among the Support File Search Paths. And it won't matter how many are in the list, or how many of them [if any] it couldn't find.
@Kent1Cooper wrote:
(foreach blk '("SpecialBlock1" "SpecialBlock2"); add as many as you like
(if (or (tblsearch "block" blk) (findfile (strcat blk ".dwg")))
; already in drawing or available in Support File Search Paths?
(command "_.insert" blk (getvar 'viewctr) "" "" ""); temporarily
); if
); foreach
Hi hmsilva,
Operator_Logos_WS and Operator_Logos_PL are block names I must had mess up the layer name and block name.
Thank you for your help the lisp rotine work really good.
Hi Gary,
Thank you for your help, but the code seem to run into an error.
error:Function cancelled is the error message.
I am tring to cut down the runing time for the routine too. It's taking 2 to 3 mins to run though now.
@Anonymous wrote:
Kent, wouldn't your entnext calls have a problem with grabbing subentities? ....
In the context, since everything after the initial base-reference 'entl' object [the last thing before the routine begins] would be a Block insertion, (entnext) finding subentities would be possible only if a Block contains Attributes. [It's not about the Block definition subentity pieces, which you can step through via (entnext) only by digging in with (tblobjname).] In a quick experiment, I find the deletion part isn't bothered by that -- the (while ....) bit successfully removes the Blocks and their Attributes, without any problems. However, if any Special Blocks might contain Attributes with non-constant values, the Insertion part of it would need to account for that possibility. Since they're being inserted only temporarily to make them non-Purge-able, no specific answer(s) to the Attribute prompt(s) would be needed, and Enter would do:
(defun C:PABE (/ entl cmde) ; = Purge All Blocks Except
(setq
entl (entlast); starting point for later in removing temporary Blocks
cmde (getvar 'cmdecho)
); setq
(setvar 'cmdecho 0)
(foreach blk '("SpecialBlock1" "SpecialBlock2"); add as many as you like
(if (or (tblsearch "block" blk) (findfile (strcat blk ".dwg")))
; already in drawing or available in Support File Search Paths?
(progn
(command "_.insert" blk (getvar 'viewctr)); temporarily -- ends with insertion point, leaves asking for X scale
(while (> (getvar 'cmdactive) 0) (command "")); default scales, rotation, Enter for any Attribute(s)
); progn
); if
); foreach
(repeat 3 (command "_.purge" "_block" "*" "_no")); or more than 3 if you prefer
(while (setq entl (entnext entl)) (entdel entl)); remove temporary ones
(setvar 'cmdecho cmde)
(princ)
); defun
Hi,
Some times ago, I wrote some LISP routines to evaluate if a block is referenced, get all references of a block definition and purge all unreferenced blocks (even nested).
The original thread at TheSwamp.
The LISP code
;; gc:GetReferences
;; Returns the unerased block reference list for the block
;;
;; Arguments
;; bname: block name
;; flag: sum of the following binary codes
;; 1 = nested in blocks
;; 2 = inserted in model space
;; 4 = inserted in paper space
(defun gc:GetReferences (bname flag / blk refs elst)
(if
(and
(setq blk (tblobjname "BLOCK" bname))
(setq refs (vl-remove-if-not
'cdr
(mapcar
(function
(lambda (x)
(if (setq elst (entget x))
(cons x (entget (cdr (assoc 330 elst))))
)
)
)
(gc:massoc 331 (entget (cdr (assoc 330 (entget blk)))))
)
)
)
)
(if (= 7 flag)
(mapcar 'car refs)
(if (< 0 flag 7)
(mapcar 'car
(vl-remove-if
(function
(lambda (x)
(wcmatch (strcase (cdr (assoc 2 (cdr x))))
(cond
((= 1 flag) "`**_SPACE*")
((= 2 flag) "~`*MODEL_SPACE")
((= 3 flag) "`*PAPER_SPACE*")
((= 4 flag) "~`*PAPER_SPACE*")
((= 5 flag) "`*MODEL_SPACE*")
((= 6 flag) "~`**_SPACE*")
)
)
)
)
refs
)
)
)
)
)
)
;; gc:IsReferenced
;; Evaluates if the block is referenced
;;
;; Argument
;; bname: block name
(defun gc:IsReferenced (bname / blk)
(and
(setq blk (tblobjname "BLOCK" bname))
(setq blkRec (cdr (assoc 330 (entget blk))))
(setq blkRefs (vl-remove nil (mapcar 'entget (gc:massoc 331 (entget blkRec)))))
(vl-some 'vl-consp (mapcar '(lambda (x) (entget (cdr (assoc 330 x)))) blkRefs))
)
)
;; gc:PurgeBlock
;; Purges the blocks which names matches with tha pattern
;;
;; Argument
;; pat: pattern (wildcard patterns allowed, not case sensitive)
(defun gc:PurgeBlock (pat / blk name elst blst loop)
(vl-load-com)
(while (setq blk (tblnext "BLOCK" (not blk)))
(if
(and
(wcmatch (strcase (setq name (cdr (assoc 2 blk)))) (strcase pat))
(< (cdr (assoc 70 (setq elst (entget (tblobjname "BLOCK" name))))) 4)
)
(setq blst (cons (cdr (assoc 330 elst)) blst))
)
)
(setq loop T)
(while (and loop blst)
(setq loop nil)
(foreach b blst
(or (vl-some 'entget (gc:massoc 331 (entget b)))
(progn
(setq blk (vlax-ename->vla-object b))
(vlax-for o blk
(if (= (vla-get-ObjectName o) "AcDbBlockReference")
(vla-Delete o)
)
)
(vla-delete blk)
(setq blst (vl-remove b blst))
(setq loop T)
)
)
)
)
)
;; gc:massoc
;; Returns the list of all values for the specified group code in an association list
;;
;; Arguments
;; code: group code
;; alst: association list
(defun gc:massoc (code alst)
(if (setq alst (member (assoc code alst) alst))
(cons (cdar alst) (gc:massoc code (cdr alst)))
)
)
Thank you again, I have around 143 blocks in total I think that may be a bit too much for the command line.
I'll try Kent code and see if It will run faster.
You can try this, adapted from the upper routines
;; gc:PurgeAllBlocksExcept ;; Purges all the blocks which names do not matches with the pattern ;; ;; Argument ;; pat: pattern (wildcard patterns allowed, not case sensitive) (defun gc:PurgeAllBlocksExcept (pat / blk name elst blst loop) (vl-load-com) (while (setq blk (tblnext "BLOCK" (not blk))) (if (and (not (wcmatch (strcase (setq name (cdr (assoc 2 blk)))) (strcase pat))) (< (cdr (assoc 70 (setq elst (entget (tblobjname "BLOCK" name))))) 4) ) (setq blst (cons (cdr (assoc 330 elst)) blst)) ) ) (setq loop T) (while (and loop blst) (setq loop nil) (foreach b blst (or (vl-some 'entget (gc:massoc 331 (entget b))) (progn (setq blk (vlax-ename->vla-object b)) (vlax-for o blk (if (= (vla-get-ObjectName o) "AcDbBlockReference") (vla-Delete o) ) ) (vla-delete blk) (setq blst (vl-remove b blst)) (setq loop T) ) ) ) ) ) ;; gc:massoc ;; Returns the list of all values for the specified group code in an association list ;; ;; Arguments ;; code: group code ;; alst: association list (defun gc:massoc (code alst) (if (setq alst (member (assoc code alst) alst)) (cons (cdar alst) (gc:massoc code (cdr alst))) ) )
Then run:
(gc:PurgeAllBlocksExcept "Operator_Logos_WS,Operator_Logos_PL")
I ran your code and given me an error that said error:automation error. object is referenced , so I look into it and changed (vl-some 'entget (gc:massoc 331 (entget b))) to (vl-some 'entget (gc:massoc 331 (entget blst))) but that also give me an error, then I changed to (vl-some 'entget (gc:massoc 331 blst)) still not working.
the error message said: bad association list__________________then a long list of entity name:
Can't find what you're looking for? Ask the community or share your knowledge.