Duplicate a block definition

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

 

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.

 

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")
)

 

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.

 

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.

 

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).

 

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

 

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

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

 

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.

 

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

 

Nice John.

 

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
)

 

;; 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
|

 

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."))
)
:]

 

<mmm> Yes! ;^)

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


| 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

 

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!

 

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!