Community
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
@amyyoyo1 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.
Kent Cooper, AIA 
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.
Kent Cooper, AIA
@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.
Kent Cooper, AIA
@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
@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
Kent Cooper, AIA
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)))
)
)
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")
![Autodesk Design & Make Report](https://forums.autodesk.com/t5/image/serverpage/image-id/1350519iCB55845EBFC43016/image-size/large?v=v2&px=999" "Autodesk Design & Make Report")
