Replace only selected blocks with a different one LISP

[Anonymous]

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

[john.uhden]

@Kent1Cooper ,

I think we should not "let @john.uhden do the modification."

He'll never get to it.

[pdecanio1]

---

@Kent1Cooper wrote:

---

@pendean wrote:
.... the simpler method of INSERTing an old file into a Master template file with your new block definitions already in place ....

---

.... depends on the new Blocks all having the same names as the old ones.  @pdecanio1, is that always the case for you?

---

No in my case the block names are typically not the same. If they were I would just copy old drawings to a new template.  This is more a Old block name could be _Connector and the new block is _Connector v2 where as the new block now has attributes instead of text.