;;; Replace selected blocks with a different one
;;;(replacing blocks and transferring attributes and some properties like layer, rotation and scale).
;;; Saved from: https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/replace-only-selected-blocks-with-a-different-one-lisp/td-p/6933210
(defun c:cbb(/ iCnt bSet cFlg nBlc cVal pLst
bNam aLst aDoc nBlc aSp cAt rLst)
(vl-load-com)
(defun Set_Initial_Setenv(varLst)
(mapcar
'(lambda(v)(if(not(getenv(car v)))(setenv(car v)(cadr v))))
varLst)
); end of Set_Initial_Setenv
(defun Unblock_All_Layers(/ aDoc layCol actLay outLst)
(setq aDoc(vla-get-ActiveDocument
(vlax-get-acad-object))
layCol(vla-get-Layers aDoc)
actLay(vla-get-ActiveLayer aDoc)
); end setq
(vlax-map-collection layCol
(function
(lambda(x)
(setq outLst
(cons
(list x
(vla-get-Lock x)
(vla-get-Freeze x)
)outLst)
); end setq
(vla-put-Lock x :vlax-false)
(if(not(equal x actLay))
(vla-put-Freeze x :vlax-false)
); end if
); end lambda
); end function
); end vlax-map-collection
outLst
); end of Unblock_All_Layers
(defun Restore_All_Layer_States(Lst / actLay)
(setq actLay(vla-get-ActiveLayer
(vla-get-ActiveDocument
(vlax-get-acad-object))))
(mapcar
(function
(lambda(x)
(vla-put-Lock(car x)(cadr x))
(if(not(equal actLay(car x)))
(vla-put-Freeze(car x)(last x))
); end if
)
)
Lst
)
(princ)
); end of Restore_All_Layer_States
(Set_Initial_Setenv '(("xchange:layer" "Yes")("xchange:scale" "Yes")
("xchange:rotation" "Yes")("xchange:attributes" "Yes")))
(princ "\n<<>> ")
(if(setq bSet(ssget '((0 . "INSERT"))))
(progn
(while(not cFlg)
(princ
(strcat "\nOptions: Layer = "(getenv "xchange:layer")
", Scale = " (getenv "xchange:scale")
", Rotation = " (getenv "xchange:rotation")
", Attributes = " (getenv "xchange:attributes")))
(initget "Options")
(setq nBlc(entsel "\nSelect new block or [Options] > "))
(cond
((and
(= 'LIST(type nBlc))
(equal '(0 . "INSERT")(assoc 0(entget(car nBlc))))
); end and
(setq nBlc(vlax-ename->vla-object(car nBlc))
cFlg T); end setq
); end condition #1
((= 'LIST(type nBlc))
(princ "\n This isn't block ")
); end condition #2
((= "Options" nBlc)
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block layer [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:layer" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block scale [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:scale" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block rotation [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:rotation" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit attributes with similar tags [Yes/No] : ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:attributes" cVal))
); end condition #3
); end cond
); end while
(setq aDoc(vla-get-ActiveDocument(vlax-get-acad-object))
bNam(vla-get-Name nBlc)
aSp(vla-ObjectIdToObject aDoc(vla-get-OwnerId nBlc))
iCnt 0
); end setq
(vla-StartUndoMark aDoc)
(setq rLst(Unblock_All_Layers))
(foreach b(mapcar 'vlax-ename->vla-object
(vl-remove-if 'listp
(mapcar 'cadr(ssnamex bSet))))
(if(= :vlax-true(vla-get-HasAttributes b))
(setq aLst
(mapcar '(lambda (a)
(list (vla-get-TagString a)
(vla-get-TextString a)))
(vlax-safearray->list
(vlax-variant-value (vla-GetAttributes b)))))
); end if
(setq nBlc(vla-InsertBlock aSp (vla-get-InsertionPoint b)bNam 1.0 1.0 1.0 0.0))
(if(= "Yes"(getenv "xchange:layer"))
(vla-put-Layer nBlc(vla-get-Layer b))
); end if
(if(= "Yes"(getenv "xchange:scale"))
(progn
(vla-put-XScaleFactor nBlc(vla-get-XScaleFactor b))
(vla-put-YScaleFactor nBlc(vla-get-YScaleFactor b))
(vla-put-ZScaleFactor nBlc(vla-get-ZScaleFactor b))
); end progn
); end if
(if(= "Yes"(getenv "xchange:rotation"))
(vla-put-Rotation nBlc(vla-get-Rotation b))
); end if
(if
(and
(= "Yes"(getenv "xchange:attributes"))
(= :vlax-true(vla-get-HasAttributes nBlc))
); end and
(foreach i(mapcar '(lambda (a)(list(vla-get-TagString a)a))
(vlax-safearray->list
(vlax-variant-value(vla-GetAttributes nBlc))))
(if(setq cAt(assoc(car i)aLst))
(vla-put-TextString(last i)(last cAt))
); end if
); end foreach
); end if
;(vla-Delete b)
(setq iCnt(1+ iCnt))
); end foreach
(Restore_All_Layer_States rLst)
(vla-EndUndoMark aDoc)
(princ(strcat "\n" (itoa iCnt) " block(s) was replaced. "))
); end progn
(princ "\n Nothing selected " )
); end if
(princ)
);
(alert "\nMake select similar on All background blocks before invoke CBB")
(princ "\nType CBB to replace or add blocks")
(c:cbb)
