Topic: Block Copy with nentsel, xref question

[CAB]

Help needed.
This is a work in progress so any suggestions are welcome.
Stig got me looking into the nentsel command.
I was trying to create a routine like ncopy but to copy one level
down. Where as ncopy copies the bottom level entity, my routine would
copy a block within a block or entity if it was an object in the parent block.
Well it works on blocks but I can't seem to conquer the xref blocks.
Caution, when copying from an xref it crashes ACAD...

My problem is in creating a copy of the block or entity from within an xref.
The single entity is created but the location (coordinates) are incorrect.
Reading something about using trans when digging into an xref. Don't understand
it yet though.

I tried borrowing a block copy routine shown below, but no workie.

Thanks in advance.

CAB

Code: [Select]

;;;  Nested Block Copy by Charles Alan Butler
;;;         Copyright 2004
;;;  by Precision Drafting & Design All Rights Reserved.
;;;  Contact at ab2draft@TampaBay.rr.com
;;;
;;;   Version 1.0 Alpha March 24, 2004
;;;
;;; DESCRIPTION
;;;
;;;
;;;  Limitations
;;;
;;;
;;; Command: nbcopy
;;;
;;;   THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT EXPRESS OR IMPLIED
;;;   WARRANTY.  ALL IMPLIED WARRANTIES OF FITNESS FOR ANY PARTICULAR
;;;   PURPOSE AND OF MERCHANTABILITY ARE HEREBY DISCLAIMED.
;;;                                                                    ;
;;;  You are hereby granted permission to use, copy and modify this    ;
;;;  software without charge, provided you do so exclusively for       ;
;;;  your own use or for use by others in your organization in the     ;
;;;  performance of their normal duties, and provided further that     ;
;;;  the above copyright notice appears in all copies and both that    ;
;;;  copyright notice and the limited warranty and restricted rights   ;
;;;  notice below appear in all supporting documentation.              ;
;;;

(defun c:nbcopy (/ ent elst pt bname obj)
  (if (setq ent (getsubentity))
    (if (= (cdr (assoc 0 (setq elst (entget (car ent))))) "INSERT")
      ;; ==================================
      ;; block found                      
      ;; ==================================
      (progn
        (setq bname (cdr (assoc 2 elst))
              x (caddr ent)
              y (cadddr ent)
              z (nth 4 ent)
              )
        ;; optional insert method
        ;;(command "-.insert" bname pause "" "" "")
        (if (setq pt (getpoint "\nPick point to insert block. "))
          (command "-insert" bname pt x y "")
        ) ; endif
      ) ; end progn
      ;; ==================================
      ;;  else entity found                
      ;; ==================================
      (progn ; create a copy
        (foreach i '(2 3 70 74 100 67 330 5 410)
          (setq elst (vl-remove (assoc i elst) elst))
        )
        (setq elst (subst '(8 . "0") (assoc 8 elst) elst))
       (entmake elst); created at 0,0
       (setq obj (entlast))
        (if (not(= x y z 1)); must scale object
          (command ".scale" obj "" "0,0" x "")
          ); endif
;       (command ".copybase" (cdr (assoc 10 elst)) obj "")
        (command ".copybase" "0,0" obj "")
        (entdel obj)
        (command ".pasteclip" pause)
        ;; optional paste method
        ;|(if (setq pt (getpoint "\nPick point to insert object."))
          (progn
            (command ".pasteclip" pt)
          ) ; end progn
        ) ;endif|;
        (princ)
      ) ; end progn
    ) ; endif
    (prompt "\nNothing selected.")
  ) ; endif
) ; end defun


;;;==========================================================
;;;       Function to get user selected entity
;;;
;;;   Returns:
;;;       if single entity, entity name & pick point
;;;       if block, entity name, pick point & scale factors x y z
;;;
;;;==========================================================
(defun getsubentity (/ ent entlst elst)
  (setq x-scale 1 ; needed for scaled blocks
        y-scale 1
        z-scale 1
  )
  (if (setq ent (nentsel "\nSelect object to copy."))
    (progn
      (cond
        ((= (length ent) 2) ; not a block object
         ent
        )
        (t ; is a block or x-ref object
         (setq entlst (cadddr ent)) ; list of blocks
         (setq pkpt (cadr ent)) ; Save Pick Point
         (if (= (length entlst) 1) ;Object within a single block
           (setq elst (entget (car ent)))
           ;;  Else  =============================
           (progn ; block within a block
             (while (> (length entlst) 2)
               (if (= (cdr (assoc 0 (entget (car entlst)))) "INSERT")
                 ;; get scale of nested blocks
                 (getscale (car entlst))
               ) ; endif
               (setq entlst (cdr entlst))
             ) ; end while
             ;; next to last name
             (setq elst (entget (car entlst)))
           ) ; end progn
         ) ; endif
         ;;  =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
         ;;  get scales of each sub block so you can insert copied
         ;;  block at a matching size as the copied from block    
         ;;  =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
         (if (= (cdr (assoc 0 elst)) "INSERT")
           ;; get scale of block to copy
           (getscale (cdr (assoc -1 elst)))
         )
         ;; get scale of parent block
         (if (= (length entlst) 1)
         (getscale (cdr (assoc -1 (entget (car entlst)))))
         (getscale (cdr (assoc -1 (entget (cadr entlst)))))
           )
         ;;  =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
         ;;  Check for xref block
         (if (and (= (cdr (assoc 0 elst)) "INSERT")
                  (wcmatch (cdr (assoc 2 elst)) "*|*")
             )
           (progn ; block is within an xref
             ;; make new block name by removing the pipe
             (setq ename (vl-string-subst
                           ""
                           "|"
                           (cdr (assoc 2 elst))
                         )
             )
             ;; create a new matching block
             (if (not (tblsearch "BLOCK" ename))
               (progn
;;;
;;;  Need help here to create a new block from
;;;  the xref block
;;;
                 ;; tyied this sub routine
                 (CloneBlock (cdr (assoc 2 elst)) ename)
               )
             )
           )
           ;;  else we are done
           ;; return the entity name, pick point & scale factors
           (list (cdr (assoc -1 elst)) pkpt x-scale y-scale z-scale)
         ) ; endif
        )
      ) ; end cond
    ) ; end progn
  ) ; endif
) ; end defun

(defun getscale (ent)
  (setq tmpelst (entget ent)
        x       (cdr (assoc 41 tmpelst))
        y       (cdr (assoc 42 tmpelst))
        z       (cdr (assoc 43 tmpelst))
  )
  (if x
    (setq x-scale (* x-scale x))
  )
  (if y
    (setq y-scale (* y-scale y))
  )
  (if z
    (setq z-scale (* z-scale z))
  )

)

;;;  not mine  CAB

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

[CAB]

Revised the code above.
The crash was because the xref layers are off limits.
So i create the entity on layer 0 for now.

[Keith™]

Cab, you should be able to retrieve the entity name and from that determine what layer it is on, linetype, color etc....

I had a program I used some time ago, I will look and see if I can find it.

You should be able to nentsel an object, grab the entity list containing all of the data required to simply entmake the entity in the document outside of the block or xref. By doing so, you will match exactly the current properties and position in the drawing of the xref/block object exactly.
Now, keep in mind that when you nentsel an object you also should grab the parent entity (and it's parent entity for nested objects) until you reach the top level block or xref. To recreate the block in the exact space as the original (relationally that is) you will need to use TRANS to make sure it is put back in the correct location according to UCS.
Also remember that the entity location reference returned by nentsel is in relation to the insertion point of the parent block, not the current UCS, so nested objects will have to be realigned according to the insertion point of the parent block.

Example...
Block A contains Block B which contains Block C
Block A insbase point is 0,0,0
Block B insbase point is 12,0,0
Block C insbase point is 12,12,0

You grab an entity defined in Block C It's location is defined as 0,0,0. This means that within Block B it's relative location is -12,-12,0 and within Block A it's relative position is -24,-12,0 and within the drawing the relative position is -24,-12,0 (because insbase is 0,0,0 in Block A, but you inserted this block at 100,100,0 so, to make this show up relative to 100,100,0, you have to change the coords to 76,88,0 It will now be directly on top of the original entity.
If the UCS is off, then you will have to use TRANS to convert the entity coordinates from WCS to UCS.

I certainly hope I have not confused you.....

On second thought ... maybe someone else has a magic bullet that can handle this much easier.