Duplicate a block definition

[Mike Evans]

I'm attempting to duplicate a block definition and give it a new name. The code at the bottom of this message is my attempt at this. I pass the "create-dup-def" function the name of an existing block and the new name to use, and it should create a duplicate definition of the existing block with the new name.

It appears to do this, but when I check the entity data of the new block definition, the "1" group code (xref path name) which should be "", instead has the name of the new block (in other words, group "1" and group "2" have the same values). Any ideas why this is happening? It seems defining an xref path for a non-xref block would cause problems.

Which brings me to my next problem: if I attempt to make a duplicate of the new block definition, I get "Exception occurred: 0xC0000005 (Access Violation)" errors. Is this due to the incorrect group "1" value? What else could be causing this?

Basically, I need to know what really obvious thing I'm overlooking (and all the not-so-obvious things).

Thanks for any help you can provide.

;;; *** CREATE DUPLICATE BLOCK DEFINITION FUNCTION ***
(DEFUN create-dup-def (exist-block-name new-block-name / exist-block-def object-entity-name new-block-def ) ;; ;; GET EXISTING BLOCK DEFINITION (SETQ exist-block-def (ENTGET (SETQ object-entity-name (TBLOBJNAME "BLOCK" exist-block-name)) ) ;_ ENTGET ) ;_ SETQ ;; ;; START BLOCK DEFINITION (SETQ new-block-def ;; REPLACE EXISTING BLOCK NAME WITH NEW BLOCK NAME (SUBST (CONS 2 new-block-name) (ASSOC 2 exist-block-def) exist-block-def ) ;_ SUBST ) ;_ SETQ (ENTMAKE new-block-def) ;; ;; COPY BLOCK ELEMENTS (WHILE (SETQ object-entity-name (ENTNEXT object-entity-name)) (ENTMAKE (ENTGET object-entity-name)) ) ;_ WHILE ;; ;; COMPLETE BLOCK DEFINITION (ENTMAKE (LIST (CONS 0 "ENDBLK"))) ;; ) ;_ DEFUN

 

[ECCAD]

Tried your example code: Got the following.
Wierd that -1 and 2 are 'new' blockname.!

Command: (setq exist-block-name "ACOIL")
"ACOIL"

Command: (SETQ exist-block-def (ENTGET (SETQ object-entity-name (TBLOBJNAME "BLOCK" exist-block-name)))) ((-1 . <Entity name: 4009fb50>) (0 . "BLOCK") (330 . <Entity name: 4009fb30>) (5 . "5BA") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockBegin") (70 . 0) (10 0.0 0.0 0.0) (-2 . <Entity name: 4009fb38>) (2 . "acoil") (1 . ""))

Command: (SETQ NEW-BLOCK-NAME "BBCOIL")
"BBCOIL"

Command: (SETQ new-block-def (SUBST (CONS 2 new-block-name)(ASSOC 2 exist-block-def) exist-block-def)) ((-1 . <Entity name: 4009fb50>) (0 . "BLOCK") (330 . <Entity name: 4009fb30>) (5 . "5BA") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockBegin") (70 . 0) (10 0.0 0.0 0.0) (-2 . <Entity name: 4009fb38>) (2 . "BBCOIL") (1 .
""))

Command: (ENTMAKE new-block-def)
((-1 . <Entity name: 4009fb50>) (0 . "BLOCK") (330 . <Entity name: 4009fb30>) (5 . "5BA") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockBegin") (70 . 0) (10 0.0 0.0 0.0) (-2 . <Entity name: 4009fb38>) (2 . "BBCOIL") (1 .
""))

Command: (WHILE (SETQ object-entity-name (ENTNEXT object-entity-name))(ENTMAKE (ENTGET object-entity-name))) ((-1 . <Entity name: 4009fb48>) (0 . "LINE") (330 . <Entity name: 4009fb30>) (5 "5B9") (100 . "AcDbEntity") (67 . 0) (8 . "0") (6 . "Continuous") (100 . "AcDbLine") (10 3.0 0.0 0.0) (11 6.0 0.0 0.0) (210 0.0 0.0 1.0))

Command: (ENTMAKE (LIST (CONS 0 "ENDBLK")))
"BBCOIL"

Command: (setq exist-block-name "BBCOIL")
"BBCOIL"

Command: (SETQ exist-block-def (ENTGET (SETQ object-entity-name (TBLOBJNAME ((((_> "BLOCK" exist-block-name)))) ((-1 . <Entity name: 400f1080>) (0 . "BLOCK") (330 . <Entity name: 400f1078>) (5 . "688") (100 . "AcDbEntity") (67 . 0) (8 . "0") (100 . "AcDbBlockBegin") (70 . 0) (10 0.0 0.0 0.0) (-2 . <Entity name: 400f1088>) (2 . "BBCOIL") (1 .
"BBCOIL"))

Command: DDINSERT

Specify insertion point or [Scale/X/Y/Z/Rotate/PScale/PX/PY/PZ/PRotate]:
Command: Z ZOOM
Specify corner of window, enter a scale factor (nX or nXP), or [All/Center/Dynamic/Extents/Previous/Scale/Window] <real time>: W
Specify first corner: Specify opposite corner:
Command: RE REGEN Regenerating model.

Command: LIST
Select objects: 1 found

Select objects:
BLOCK REFERENCE Layer: "0"
Space: Model space
Color: BYLAYER Linetype: "CONTINUOUS"
Handle = 68D
"BBCOIL"
at point, X= 378.0000 Y= 222.0000 Z= 0.0000
X scale factor 1.0000
Y scale factor 1.0000
rotation angle 0
Z scale factor 1.0000

Command: LIST
Select objects:
Command: (SETQ SS (SSGET))

Select objects: 1 found

Select objects: <Selection set: 2>

Command: (setq a (ssname ss 0))
<Entity name: 400f10a8>

Command: (setq b (entget a))
((-1 . <Entity name: 400f10a8>) (0 . "INSERT") (330 . <Entity name: 400a2cb8>) (5 . "68D") (100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (6 . "Continuous") (100 . "AcDbBlockReference") (2 . "BBCOIL") (10 378.0 222.0 0.0) (41 . 1.0) (42 . 1.0) (43 . 1.0) (50 . 0.0) (70 . 0) (71 . 0) (44 . 0.0) (45 .
0.0) (210 0.0 0.0 1.0))

Clueless.

 

[Jim Claypool]

I don't know why it does what it does but here is a work around.

(DEFUN create-dup-def (exist-block-name new-block-name ) (command ".wblock" "temp" "block" exist-block-name ".insert" (strcat new-block-name "=temp") nil ) (vl-file-delete "temp.dwg")
)

 

[Jason Piercey]

Certainly strange that dxf codes 1 and 2 are the same.
If it has always been this way (after entmaking), I've
never noticed.

Using 2004 here at the moment.

 

[John Uhden]

Seems that (entmake) creates that side effect, though I didn't encounter any crashes with yours using 2002. Please try my first creation of the new year <WATCH FOR WORD WRAP>... (defun CloneBlock (Old New / Doc Blocks Block Objects Array) ;; CloneBlock.lsp (01-01-04), John F. Uhden, Cadlantic." ;; Function dedicated to Mike Evans to create a new block ;; from an existing block. ;; Arguments:
;; Old - existing block name as a string
;; New - new block name as a string
;; Returns:
;; The block record as a VLA-Object if successful, or ;; nil if not successful. ;; Note:
;; Can be used to create an anonymous block
;; using "*U" as the New name
(gc)
(vl-load-com)
(and
(or
(tblobjname "block" Old)
(prompt (strcat "\nNo block definition named " Old))
)
(if (tblobjname "block" New)
(prompt (strcat "\nBlock named " New " exists."))
1
)
(setq Doc (vla-get-ActiveDocument (vlax-get-acad-object)) Blocks (vla-get-blocks Doc) ) (setq Old (vla-item Blocks Old)) (or (setq Block (vla-add Blocks (vla-get-origin Old) New)) (prompt (strcat "\nUnable to make block named " New)) ) (vlax-for Item Old (setq Objects (cons Item Objects)) ) (setq Array (vlax-make-safearray vlax-vbObject (cons 0 (1- (length Objects)))) ) (vlax-safearray-fill Array (reverse Objects)) (or (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-copyobjects (list Doc Array Block 'IDpairs) ) ) ) (setq Block (prompt "\nUnable to add objects to block definition.")) ) ) Block )

It could use either more or less error trapping, but it's a start.

 

[Tony Tanzillo]

Do you think you're copying entities using this?

You're not.

ENTMAKE and ENTGET use different conventions in the entity data list that they take/return respectively.

For example, if an entity's color is 'BYLAYER', (entget) omits it from the resulting list. If you give (entmake) a list without a color, it uses the _current_ color (CECOLOR) for the color, not 'BYLAYER'.

Hence, (entmake (entget <ename>)) does _NOT_ create an exact copy of an entity.

It's a common pitfall that has plauged LISP programmers for as long as I can remember (10 years ago, I chastised Autodesk for not making this clear perfectly in their docs).

You need to forget about (ENTxxxx) functions and learn to use the ActiveX API (vla-CopyObjects in this case).

 

[ECCAD]

Hey Tony,
Don't beat ME up on this one, I never use ENTMAKE for any reason. I was just trying his code example. I would just wblock / insert the new block / name it what I want. Gees..
Bob

 

[Tony Tanzillo]

Sorry, I thought it was your code. In any event, the advice stands. Not a beating, just a lesson learned.

Hey Tony,
Don't beat ME up on this one, I never use ENTMAKE for any reason. I was just trying his code example. I would just

wblock / insert the new block / name it what I want.

 

[Tony Tanzillo]

See my respose in this thread. You can't "copy"
entities using (entmake (entget ...)). You can
either use WBLOCK/INSERT or the vla-CopyObjects
method to copy a block's definition.

 

[Doug Broad]

Tony,
Thanks for bringing the points up. Good for all
of us to be reminded of those stumbling blocks.

 

[Doug Broad]

Nice John.

 

[John Uhden]

Here's a little better and commented version that uses the less obfuscated (vlax-invoke) methodology.

(defun CloneBlock (Old New / Doc Blocks Block Objects)
;; CloneBlock.lsp (01-01-04), John F. Uhden, Cadlantic. ;; Revised (01-04-04):
;; Added in-line comments.
;; Allowed for cloning empty blocks, but with a prompt. ;; Changed to use of simpler (vlax-invoke) methodology. ;; Function dedicated to Mike Evans to create a new block ;; from an existing block. ;; Arguments:
;; Old - existing block name as a string
;; New - new block name as a string
;; Returns:
;; The block record as a VLA-Object if successful, or ;; nil if not successful. ;; Note:
;; Can be used to create an anonymous block
;; using "*U" as the New name
(gc)
(vl-load-com)
(and
;; Check for the existence of the Old block by name, or ;; cease further evaluation with a (prompt), which always ;; returns nil (or (tblobjname "block" Old) (prompt (strcat "\nNo block definition named " Old)) ) ;; Check for the existence of the New block by name. ;; If it exists, then cease further evaluation with a ;; (prompt), which always returns nil (if (tblobjname "block" New) (prompt (strcat "\nBlock named " New " exists.")) 1 ) ;; If so far so good, set the symbols for the ;; ActiveDocument object and its Blocks collection. (setq Doc (vla-get-ActiveDocument (vlax-get-acad-object)) Blocks (vla-get-blocks Doc) ) ;; Convert the Old value to its VLA-Object block record. (setq Old (vla-item Blocks Old)) ;; Either create a New block definition, which will be ;; empty, or cease further evaluation with a (prompt), ;; which always returns nil (or (setq Block (vla-add Blocks (vla-get-origin Old) New)) (prompt (strcat "\nUnable to make block named " New)) ) ;; Either build a list of objects contained in the Old ;; block definition, or cease further evaluation with ;; a (prompt), which always returns nil. ;; Nevertheless, the New block has been created. (or (vlax-for Item Old (setq Objects (cons Item Objects)) ) (prompt "\nBlock definition contains no objects.") ) ;; Note that the (vlax-invoke) methodology used in this ;; example cannot return the optional 'IDPairs variant. (vl-catch-all-error-p (vl-catch-all-apply 'vlax-invoke (list Doc 'CopyObjects (reverse Objects) Block) ) ) ;; If there was an error, then evaluation continues, ;; so delete the erroneous block record, (not (vla-delete Block)) ;; and set its value to nil via (prompt) (setq Block (prompt "\nUnable to add objects to block definition.")) ) ;; Return the block record VLA-Object, if it exists. Block )

 

[R. Robert Bell]

;; Check for the existence of the New block by name.
;; If it exists, then cease further evaluation with a
;; (prompt), which always returns nil
(cond ((not (tblobjname "block" New)))
((prompt (strcat "\nBlock named " New " exists."))))

I don't know if it is clearer, or not... ;-)

--
R. Robert Bell, MCSE
www.AcadX.com

| Here's a little better and commented version that uses the less obfuscated | (vlax-invoke) methodology. | | (defun CloneBlock (Old New / Doc Blocks Block Objects) | ;; CloneBlock.lsp (01-01-04), John F. Uhden, Cadlantic. | ;; Revised (01-04-04):
| ;; Added in-line comments.
| ;; Allowed for cloning empty blocks, but with a prompt. | ;; Changed to use of simpler (vlax-invoke) methodology. | ;; Function dedicated to Mike Evans to create a new block | ;; from an existing block. | ;; Arguments:
| ;; Old - existing block name as a string
| ;; New - new block name as a string
| ;; Returns:
| ;; The block record as a VLA-Object if successful, or | ;; nil if not successful. | ;; Note:
| ;; Can be used to create an anonymous block
| ;; using "*U" as the New name
| (gc)
| (vl-load-com)
| (and
| ;; Check for the existence of the Old block by name, or | ;; cease further evaluation with a (prompt), which always | ;; returns nil | (or | (tblobjname "block" Old) | (prompt (strcat "\nNo block definition named " Old)) | ) | ;; Check for the existence of the New block by name. | ;; If it exists, then cease further evaluation with a | ;; (prompt), which always returns nil | (if (tblobjname "block" New) | (prompt (strcat "\nBlock named " New " exists.")) | 1 | ) | ;; If so far so good, set the symbols for the | ;; ActiveDocument object and its Blocks collection. | (setq Doc (vla-get-ActiveDocument (vlax-get-acad-object)) | Blocks (vla-get-blocks Doc) | ) | ;; Convert the Old value to its VLA-Object block record. | (setq Old (vla-item Blocks Old)) | ;; Either create a New block definition, which will be | ;; empty, or cease further evaluation with a (prompt), | ;; which always returns nil | (or | (setq Block (vla-add Blocks (vla-get-origin Old) New)) | (prompt (strcat "\nUnable to make block named " New)) | ) | ;; Either build a list of objects contained in the Old | ;; block definition, or cease further evaluation with | ;; a (prompt), which always returns nil. | ;; Nevertheless, the New block has been created. | (or | (vlax-for Item Old | (setq Objects (cons Item Objects)) | ) | (prompt "\nBlock definition contains no objects.") | ) | ;; Note that the (vlax-invoke) methodology used in this | ;; example cannot return the optional 'IDPairs variant. | (vl-catch-all-error-p | (vl-catch-all-apply | 'vlax-invoke | (list Doc 'CopyObjects (reverse Objects) Block) | ) | ) | ;; If there was an error, then evaluation continues, | ;; so delete the erroneous block record, | (not (vla-delete Block)) | ;; and set its value to nil via (prompt) | (setq Block (prompt "\nUnable to add objects to block definition.")) | ) | ;; Return the block record VLA-Object, if it exists. | Block | ) | | -- | John Uhden, Cadlantic | <the e-mail address is bogus> | http://www.cadlantic.com | Sea Girt, NJ |

 

[John Uhden]

Thanks, Robert. I'd call that a push. Actually this is more in keeping with the style, after the work of der Lispmeister Steph(and) Koster.. (or (not (tblsearch "block" New)) (prompt (strcat "\nBlock named " New " exists.")) )
:]

 

[R. Robert Bell]

<mmm> Yes! ;^)

 

[Mike Evans]

Thank you, everyone, for all of your help and input. Besides answering my questions and solving my problems, you've given me a lot to absorb that will hopefully improve my programming.

Mr. Uhden, thank you so much for your "first creation of the new year." At the very least, you saved me hours (days?) trying to find my way through the online "ActiveX and VBA Reference." Having the code in front of me certainly made grasping the concepts a lot easier!

 

[John Uhden]

Excellent!
Make sure you look back up the thread and get the better version. Always study the responses, as most times the solutions provided here are improved through the keen minds of wise and generous responders.
Happy New Year!