Message 1 of 22
Replace only selected blocks with a different one LISP
Not applicable
03-09-2017
12:00 AM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello world,
I found this nice LISP on a CADTutor forum (kudos to Smirnoff) for replacing block and transferring attributes and some properties (layer, rotation, scale). I was wondering if someone was able to upgrade the code to also take note of the dynamic block action parameters like flip state, rotation, scale etc. and transfer it to the new dynamic block that had the same parameters?
Br,
Robert
(defun c:xch(/ 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<<< Select blocks to replace >>> ")
(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] <"
(getenv "xchange:layer")">: ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:layer" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block scale [Yes/No] <"
(getenv "xchange:scale")">: ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:scale" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit old block rotation [Yes/No] <"
(getenv "xchange:rotation")">: ")))
(if(member cVal '("Yes" "No"))(setenv "xchange:rotation" cVal))
(initget "Yes No")
(setq cVal(getkword(strcat "\nInherit attributes with similar tags [Yes/No] <"
(getenv "xchange:attributes")">: ")))
(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)
); end of c:xch
