Create a new block from an existing block in autocad

[crcampbell]

In adt it is possible to right click a block and create a new block from it. In AutoCAD ( I am using version 2008 ) this function is not available. Is there a Lisp or macro that recreates this function?

I have googled and nothing relevant pops up.

Thanks in advance.

[_gile]

Hi

Something like this ?

;;; NBL (gile) 2007/05/05
;;; Creates a new block definition similar to the selected reference

(defun c:nbl (/	old-ref	new-name AcDoc Space Blocks old-name old-block new-block
	      obj new-ref)
  (vl-load-com)
  (while (not
	   (and
	     (setq old-ref (car (entsel "\nSelect the block to re-create: ")))
	     (= "INSERT" (cdr (assoc 0 (entget old-ref))))
	   )
	 )
    (princ "\nInvalid object.")
  )
  (while
    (not
      (and
	(setq
	  new-name (getstring T "\nEnter the new block name: ")
	)
	(/= new-name "")
	(null (tblsearch "BLOCK" new-name))
      )
    )
     (princ "\nInvalid name.")
  )
  (setq	AcDoc	  (vla-get-ActiveDocument (vlax-get-acad-object))
	Space	  (if (= (getvar "CVPORT") 1)
		    (vla-get-PaperSpace AcDoc)
		    (vla-get-ModelSpace AcDoc)
		  )
	Blocks	  (vla-get-Blocks acDoc)
	old-ref	  (vlax-ename->vla-object old-ref)
	old-name  (if (vlax-property-available-p old-ref 'EffectiveName)
		    (vla-get-EffectiveName old-ref)
		    (vla-get-name old-ref)
		  )
	old-block (vla-item Blocks old-name)
	new-block (vla-add Blocks
			   (vlax-3d-point '(0 0 0))
			   new-name
		  )

  )
  (vlax-for o old-block
    (setq obj (cons o obj))
  )
  (vlax-invoke AcDoc 'CopyObjects obj new-block)
  (and (vlax-property-available-p old-block 'Units)
       (vla-put-Units new-block (vla-get-Units old-block))
  )
  (setq	new-ref
	 (vla-insertblock
	   Space
	   (vlax-3d-point '(0 0 0))
	   new-name
	   (vla-get-XScaleFactor old-ref)
	   (vla-get-YScaleFactor old-ref)
	   (vla-get-ZScaleFactor old-ref)
	   (vla-get-Rotation old-ref)
	 )
  )
  (vla-put-Normal new-ref (vla-get-Normal old-ref))
  (vla-put-InsertionPoint
    new-ref
    (vla-get-InsertionPoint old-ref)
  )
  (if (= (vla-get-HasAttributes old-ref) :vlax-true)
    (progn
      (setq old-att (mapcar '(lambda (att) (cons (vla-get-TagString att) att))
			    (vlax-invoke old-ref 'getAttributes)
		    )
	    new-att (mapcar '(lambda (att) (cons (vla-get-TagString att) att))
			    (vlax-invoke new-ref 'getAttributes)
		    )
      )
      (foreach att new-att
	(foreach prop (list
			'Alignment   'Backward	  'Color       'FieldLength
			'Height	     'InsertionPoint	       'Invisible
			'Layer	     'TextString  'Linetype    'LinetypeScale
			'Lineweight  'Material	  'Normal      'ObliqueAngle
			'Rotation    'ScaleFactor 'StyleName   'TextString
			'Thickness   'TrueColor	  'UpsideDown  'Visible
		       )
	  (if (vlax-property-available-p
		(cdr (assoc (car att) old-att))
		prop
	      )
	    (vlax-put (cdr att)
		      prop
		      (vlax-get (cdr (assoc (car att) old-att)) prop)
	    )
	  )
	)
      )
    )
  )
  (vla-delete old-ref)
  (princ (strcat "The block \"" new-name "\" has been created."))
  (princ)
)

[RobertB]

In adt it is possible to right click a block and create a new block from it. In AutoCAD ( I am using version 2008 ) this function is not available. Is there a Lisp or macro that recreates this function?

I have googled and nothing relevant pops up.

Thanks in advance.

The Block Editor has a Save As option. Does the same thing as you want, just in a different interface.

[crcampbell]

Thanks alot I will give that a try...

Hi

Something like this ?

;;; NBL (gile) 2007/05/05
;;; Creates a new block definition similar to the selected reference

(defun c:nbl (/	old-ref	new-name AcDoc Space Blocks old-name old-block new-block
	      obj new-ref)
  (vl-load-com)
  (while (not
	   (and
	     (setq old-ref (car (entsel "\nSelect the block to re-create: ")))
	     (= "INSERT" (cdr (assoc 0 (entget old-ref))))
	   )
	 )
    (princ "\nInvalid object.")
  )
  (while
    (not
      (and
	(setq
	  new-name (getstring T "\nEnter the new block name: ")
	)
	(/= new-name "")
	(null (tblsearch "BLOCK" new-name))
      )
    )
     (princ "\nInvalid name.")
  )
  (setq	AcDoc	  (vla-get-ActiveDocument (vlax-get-acad-object))
	Space	  (if (= (getvar "CVPORT") 1)
		    (vla-get-PaperSpace AcDoc)
		    (vla-get-ModelSpace AcDoc)
		  )
	Blocks	  (vla-get-Blocks acDoc)
	old-ref	  (vlax-ename->vla-object old-ref)
	old-name  (if (vlax-property-available-p old-ref 'EffectiveName)
		    (vla-get-EffectiveName old-ref)
		    (vla-get-name old-ref)
		  )
	old-block (vla-item Blocks old-name)
	new-block (vla-add Blocks
			   (vlax-3d-point '(0 0 0))
			   new-name
		  )

  )
  (vlax-for o old-block
    (setq obj (cons o obj))
  )
  (vlax-invoke AcDoc 'CopyObjects obj new-block)
  (and (vlax-property-available-p old-block 'Units)
       (vla-put-Units new-block (vla-get-Units old-block))
  )
  (setq	new-ref
	 (vla-insertblock
	   Space
	   (vlax-3d-point '(0 0 0))
	   new-name
	   (vla-get-XScaleFactor old-ref)
	   (vla-get-YScaleFactor old-ref)
	   (vla-get-ZScaleFactor old-ref)
	   (vla-get-Rotation old-ref)
	 )
  )
  (vla-put-Normal new-ref (vla-get-Normal old-ref))
  (vla-put-InsertionPoint
    new-ref
    (vla-get-InsertionPoint old-ref)
  )
  (if (= (vla-get-HasAttributes old-ref) :vlax-true)
    (progn
      (setq old-att (mapcar '(lambda (att) (cons (vla-get-TagString att) att))
			    (vlax-invoke old-ref 'getAttributes)
		    )
	    new-att (mapcar '(lambda (att) (cons (vla-get-TagString att) att))
			    (vlax-invoke new-ref 'getAttributes)
		    )
      )
      (foreach att new-att
	(foreach prop (list
			'Alignment   'Backward	  'Color       'FieldLength
			'Height	     'InsertionPoint	       'Invisible
			'Layer	     'TextString  'Linetype    'LinetypeScale
			'Lineweight  'Material	  'Normal      'ObliqueAngle
			'Rotation    'ScaleFactor 'StyleName   'TextString
			'Thickness   'TrueColor	  'UpsideDown  'Visible
		       )
	  (if (vlax-property-available-p
		(cdr (assoc (car att) old-att))
		prop
	      )
	    (vlax-put (cdr att)
		      prop
		      (vlax-get (cdr (assoc (car att) old-att)) prop)
	    )
	  )
	)
      )
    )
  )
  (vla-delete old-ref)
  (princ (strcat "The block \"" new-name "\" has been created."))
  (princ)
)

[crcampbell]

You know what I didn't even think of that, sometimes you cannot see the forrest for the trees.

Thanks much.

The Block Editor has a Save As option. Does the same thing as you want, just in a different interface.

[irneb]

This would probably not work for dynamic blocks, as neither LISP nor VBA allows for dynamic parameters inside a block definition.

Why not simply make a WBLOCK to the new name, then INSERT from that file. It shouldn't be too difficult using LISP.

[RobertB]

This [lisp-based solution] would probably not work for dynamic blocks, as neither LISP nor VBA allows for dynamic parameters inside a block definition.

Why not simply make a WBLOCK to the new name, then INSERT from that file. It shouldn't be too difficult using LISP.

Why would you go thru all that when BEdit has a SaveAs button?

[irneb]

Sure it's the easiest built-in method, but sometimes (if you're using AnnoScales extensively) just opening BEdit takes quite a while. And if you're in a PS tab it first needs to go to MS then into BEdit, so regens happen just to you can make a duplicate of a block def?

;;; Create a duplicate block definition
(defun c:DupBlock (/ en ed bname nname fname fdia)
  (if (and (setq en (entsel "\nPick block: "))
           (setq ed (entget (car en)))
           (= (cdr (assoc 0 ed)) "INSERT")
           (setq nname (getstring nil "\nNew name: "))
      ) ;_ end of and
    (progn
      (setq bname (cdr (assoc 2 ed))
            fname (strcat (getvar "TEMPPREFIX") nname ".DWG")
      ) ;_ end of setq
      (if (findfile fname)
        (vl-file-delete fname)
      ) ;_ end of if
      (setq fdia (getvar "FILEDIA"))
      (setvar "FILEDIA" 0)
      (command ".-WBLOCK" fname bname)
      (command ".-INSERT" fname)
      (setvar "FILEDIA" fdia)
    ) ;_ end of progn
  ) ;_ end of if
  (princ)
) ;_ end of defun