this is some my functions
Code:
;;; Need Express Tools !!!
;;;********* Some function from BURST.LSP ************
(Defun ITEM (N E) (CDR (Assoc N E)))
(acet-error-init (list (list "cmdecho" 0
"highlight" 1) T))
(Defun BITSET (A B) (= (Boole 1 A B) B))
(Defun bump (prmpt)(terpri)(Princ prmpt))
(Defun ATT-TEXT (AENT / TENT ILIST INUM)
(Setq TENT '((0 . "TEXT")))
(ForEach INUM '(8 6 38 39 62 67 210 10 40 1 50 41 51 7 71 72 73 11 74)
(If (Setq ILIST (Assoc INUM AENT))(Setq TENT (Cons ILIST TENT))))
(Setq tent (Subst (Cons 73 (item 74 aent))(Assoc 74 tent) tent))
(EntMake (Reverse TENT)))
(Defun LASTENT (/ E0 EN)(Setq E0 (EntLast))
(While (Setq EN (EntNext E0))(Setq E0 EN)) E0)
(Defun BURST-ONE (BNAME / BENT ANAME ENT ATYPE AENT AGAIN ENAME
ENT SS-COLOR SS-LAYER SS-LTYPE mirror ss-mirror mlast)
(Setq BENT (EntGet BNAME) BLAYER (ITEM 8 BENT) BCOLOR (ITEM 62 BENT)
BCOLOR (Cond ((> BCOLOR 0) BCOLOR)((= BCOLOR 0) "BYBLOCK")("BYLAYER"))
BLTYPE (Cond ((ITEM 6 BENT)) ("BYLAYER")))
(Setq ELAST (LASTENT))
(If (= 1 (ITEM 66 BENT))(Progn (Setq ANAME BNAME)
(While (Setq ANAME (EntNext ANAME) AENT (EntGet ANAME)
ATYPE (ITEM 0 AENT) AGAIN (= "ATTRIB" ATYPE))
(bump "Converting attributes")(ATT-TEXT AENT))))
(Progn (bump "Exploding block")(acet-explode BNAME))
(Setq SS-LAYER (SsAdd) SS-COLOR (SsAdd) SS-LTYPE (SsAdd) ENAME ELAST)
(While (Setq ENAME (EntNext ENAME))(bump "Gathering pieces")
(Setq ENT (EntGet ENAME) ETYPE (ITEM 0 ENT))
(If (= "ATTDEF" ETYPE)(Progn
(If (BITSET (ITEM 70 ENT) 2)(ATT-TEXT ENT))
(EntDel ENAME))(Progn (If (= "0" (ITEM 8 ENT))
(SsAdd ENAME SS-LAYER))(If (= 0 (ITEM 62 ENT))
(SsAdd ENAME SS-COLOR))(If (= "BYBLOCK" (ITEM 6 ENT))
(SsAdd ENAME SS-LTYPE)))))(If (> (SsLength SS-LAYER) 0)
(Progn (bump "Fixing layers")
(Command "_.chprop" SS-LAYER "" "_LA" BLAYER "")))
(If (> (SsLength SS-COLOR) 0)(Progn (bump "Fixing colors")
(Command "_.chprop" SS-COLOR "" "_C" BCOLOR "")))
(If (> (SsLength SS-LTYPE) 0)(Progn (bump "Fixing linetypes")
(Command "_.chprop" SS-LTYPE "" "_LT" BLTYPE ""))))
;;;*************** END Burst.lsp *******************************
;;Original posted http://dwg.ru/forum/printtopic.php?t=9705
;;;Function make:
;;; BLOCK - burst
;;; Dimention, region - EXPLODE
;;; Burst all nested blocks
;;;
;;;
;;; blk - Ename block's
;;; Return Selection Set with entities (set in global variable *ssRET*)
;;;
(defun exp_blk ( blk / adoc csp blk_obj)
;_BURST block and return list of object
(defun BURST-LIST (blk / ret sc ec)
(setq sc (1-(vla-get-count csp)))
(BURST-ONE blk)
(setq ec (vla-get-count csp))
(while (< sc ec)
(setq memb (vla-item csp sc))
(setq ret (append ret (list memb)))
(setq sc(1+ sc))) ret)
;_Expolde object and ssadd result to *ssREt*
(defun EXP2SS (en / sc ec)
(setq sc (1-(vla-get-count csp)))
(vl-cmdf "_.EXPLODE" en)
(setq ec (vla-get-count csp))
(while (< sc ec)
(setq memb (vla-item csp sc))
(ssadd (vlax-vla-object->ename memb) *ssRET*)
(setq sc(1+ sc))))
;_Cycle on block primitive things
;_It is necessary to explode nested blocks
;_SSadd result to *ssREt*
;_ blk - Ename block
(defun exp-blk-ss (blk / memb name)
(foreach memb (BURST-LIST Blk)
(setq name (vla-get-ObjectName memb))
(cond ((= name "AcDbBlockReference")(exp-blk-ss (vlax-vla-object->ename memb)));_BURST block
((wcmatch (strcase name) "*DIMENSION,*REGION");_Explode dimention and region
(exp2SS (vlax-vla-object->ename memb)))
(t (ssadd (vlax-vla-object->ename memb) *ssRET*)))))
(setq adoc (vla-get-activedocument (vlax-get-acad-object))
blk_obj (vlax-ename->vla-object blk)
csp (vla-ObjectIDToObject adoc (vla-get-OwnerID blk_obj)))
(if (/= (type *ssRet*) 'PICKSET)(setq *ssRET* (ssadd)))
(exp-blk-ss blk)
*ssRET*)
And Example: burst selected block and set all entities color to red
Code:
;;Example - burst block and set all entities color to red
(defun C:TEST ( / blk ss)
(if (and
(princ "\nSelect block:")
(setq ss (ssget "_:S:E:L" '((0 . "INSERT"))))
(setq blk (ssname ss 0))
)
(progn
(setq *ssRET* nil *ssRET* (ssadd))
(exp_blk blk)
(command "_CHANGE" *ssRET* "" "_P" "_C" 1 "")
)
)
(setq *ssRET* nil)
(princ)
)