Replace only selected blocks with a different one

Let's say I have 20 blocks named "george" in my dwg. Now, I would like to replace only 7 of them with the block "george2". Is there a simple way to do it just by selecting these 7 and replacing their definition without changing the other 13 "george" blocks?

Thanks...

There is a lisp routine called something like rblock that will allow you to do just that.

First select all entities or blocks which you want to change, than pick to new entity or block (must be on screen). All selected items will be replaced.

(defun c:mchange (/ ACTDOC	   COPOBJ    ERRCOUNT  EXTLST
       EXTSET	 FROMCEN   LAYCOL    MAXPT     CURLAY
       MINPT	 OBJLAY	   OKCOUNT   OLAYST    SCLAY
       TOCEN	 TOOBJ	   VLAOBJ    *ERROR*
      )

 (vl-load-com)

 (defun *ERROR* (msg)
   (if	olaySt
     (vla-put-Lock objLay olaySt)
   ); end if
   (vla-EndUndoMark actDoc)
   (princ)
 ); end of *ERROR*


 (defun GetBoundingCenter (vlaObj / blPt trPt cnPt)
   (vla-GetBoundingBox vlaObj 'minPt 'maxPt)
   (setq blPt (vlax-safearray->list minPt)
  trPt (vlax-safearray->list maxPt)
  cnPt (vlax-3D-point
	 (list
	   (+ (car blPt) (/ (- (car trPt) (car blPt)) 2))
	   (+ (cadr blPt) (/ (- (cadr trPt) (cadr blPt)) 2))
	   0.0
	 ); end list
       ); end vlax-3D-point
   ); end setq
 ); end of GetBoundingCenter

 (if (not (setq extSet (ssget "_I")))
   (progn
     (princ "\n<<< Select objects to replace >>> ")
     (setq extSet (ssget))
   ); end progn
 ); end if
 (if (not extSet)
   (princ "\n<!> Replace objects isn't selected <!>")
 ); end if
 (if
   (and
     extSet
     (setq toObj (entsel "\nSelect new object -> "))
   ); and and
    (progn
      (setq actDoc
	      (vla-get-ActiveDocument
		(vlax-get-Acad-object)
	      )
     layCol
	      (vla-get-Layers actDoc)
     extLst
	      (mapcar 'vlax-ename->vla-object
		      (vl-remove-if
			'listp
			(mapcar 'cadr (ssnamex extSet))
		      )
	      )
     vlaObj   (vlax-ename->vla-object (car toObj))
     objLay   (vla-Item	layCol
			(vla-get-Layer vlaObj)
	      )
     olaySt   (vla-get-Lock objLay)
     fromCen  (GetBoundingCenter vlaObj)
     errCount 0
     okCount  0
      ); end setq
      (vla-StartUndoMark actDoc)
      (foreach	obj extLst
 (setq toCen (GetBoundingCenter obj)
       scLay (vla-Item layCol
		       (vla-get-Layer obj)
	     )
 );end setq
 (if (/= :vlax-true (vla-get-Lock scLay))
   (progn
     (setq curLay (vla-get-Layer obj))
     (vla-put-Lock objLay :vlax-false)
     (setq copObj (vla-copy vlaObj))
     (vla-Move copObj fromCen toCen)
     (vla-put-Layer copObj curLay)
     (vla-put-Lock objLay olaySt)
     (vla-Delete obj)
     (setq okCount (1+ okCount))
   ); end progn
   (setq errCount (1+ errCount))
 ); end if
      ); end foreach
      (princ
 (strcat "\n"
	 (itoa okCount)
	 " were changed. "
	 (if (/= 0 errCount)
	   (strcat (itoa errCount) " were on locked layer! ")
	   ""
	 ); end if
 ); end strcat
      ); end princ
      (vla-EndUndoMark actDoc)
    ); end progn
    (princ "\n<!> New object isn't selected <!> ")
 ); end if
 (princ)
); end of c:mchange

Hi smirnoff.

Do you think this lisp would deal with a question I have raised here> http://www.cadtutor.net/forum/showthread.php?56768-Replace-block-and-its-attributes-with-new-block-and-attributes

I will test drive your code anyway on my problem. Any help greatly received.

Have just test driven your code Smirnoff...on first attempt it seems to have solved my problem. Thank you.

thanks, mate

works great!!

Actually, I encountered a problem... when replacing blocks with this lisp, the new blocks have all the same orientation, regardless of the orientation of the original block that has been replaced. Even the origin points are not respected ;(

Therefore, it does not help me at all.

I have about 100 windows in my floor plan, with 6 or 7 different orientations ( but all the same block). I need to change half of them to a different looking window... When I change them with this lisp, they do change, but are all in the wrong place and all of them rotated in the same way...

So this lisp doesn't work for me after all ;(

In Sketchup for example this thing can be done without problems

How about making 'george' a dynamic block with visibility states? That way you can select which 'style' of that block you want.

not an option for me unfortunately, because when importing to sketchup (which I have to do) the dyn blocks disappear. Sketch up doesn't recognize them...I started replacing them one at a time...

Actually, I encountered a problem... when replacing blocks with this lisp, the new blocks have all the same orientation, regardless of the orientation of the original block that has been replaced. Even the origin points are not respected ;(

yep I too have that problem...argh, so close.

All i need now is a combination of this lisp that does what i want attribute wise and rblock that does what i want maintaining orientation/insert wise.

back to the hunt.

Actually, I encountered a problem... when replacing blocks with this lisp, the new blocks have all the same orientation, regardless of the orientation of the original block that has been replaced. Even the origin points are not respected ;(

I can fix this problem with additional option for ex. "Inherit block orientation? [Yes/No]:" But not today. Today is Friday, pool and beer with colleagues...

I hear that! Friday is for "a cold one" not a code one!

orientation/insertion point option would rock.

Virtual beer for you if you do.

I hope that this will satisfy you. There is options of inheritance layer, scale, rotation, and attributes with the same tags from old block. Options don't need to change every time, their value is stored after AutoCAD closing and will be the same in next session.

(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

thanks, man. It works great. You are a genius

thanks, man. It works great. You are a genius

Glad that this program will useful for you. I have one more idea about it, but now in in bisiness tirip in San Peterspburg (Russia). Do this when will be back.

Bue.

This script also works great for me now. I Like the added options. Great work. Thank you.

You could of course do this without using extra Lisp:

1. Select the blocks you want replaced (and one of the new blocks) & press Ctrl+X to cut them to clipboard.
   
2. Start a new blank drawing and paste to original coordinates Alt+E+D (or Edit --> Paste to Original Coordinates)
   
3. Use the express tools' BlockReplace (Express --> Blocks --> Replace block with another block).
   
4. Choose / pick the old block's name, then the new block's name.
   
5. Ctrl+X the blocks again.
   
6. Swap to the original DWG & Alt+E+D
   

This should keep orientation, layer, properties, attributes, etc. Even attributes left as is (even if the new block doesn't have any attributes). If you want the Attributes to be changed as well, then use AttSync / BAttMan.

Smirnoff

This routine rocks!!!

Thanks for sharing

Made my life a lot easier today

~Greg

The normal routine is AutoCAD wouldn’t work correctly but this code sorted the problem straight away.

Thanks Smirnoff

just what I was after.

P

I use this lisp (xch) all the time. It works great in 2d. Can someone enhance the code to include blocks that are in different USC.

Thanks

EBrown