Copy and paste error (blocks changes!)

[rlx]

You can try if this works better. No dbx in this version

 

Start app , make selection , select drawing you want to paste in later.

This drawing is shortly opened (not sure if it works if drawing is already open)

List with blocknames is created and drawing is closed.

 

Blocknames are compared and if duplicates are found message is displayed.

You can choose 1- Stop , 2 - Rename the blocks in drawing you made the selection set (not the other drawing), or 3 - copy / paste as it is.

 

Only thing left to do is select your basepoint (or replace 'pause' with "0,0" in the code) and selection set is placed on clipboard , ready to paste.

 

 

 

;;; check before paste - rlx 2025-10-22
(defun c:cbp ( / this-dwg ss other-dwg blocknames-in-selectionset blocknames-in-other-dwg duplicate-blocknames dbx-doc)
  (setq this-dwg (vla-get-ActiveDocument (vlax-get-acad-object)))
  (if (and (setq ss (ssget)) (setq other-dwg (getfiled "Drawing to check before you paste" "" "dwg" 0)))
    (progn
      (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss)))
        (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset)))
      (if (vl-consp (setq blocknames-in-other-dwg (Get_EX_Blocknames other-dwg)))
        (setq blocknames-in-other-dwg (mapcar 'strcase blocknames-in-other-dwg)))
      (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-other-dwg))
      (if (vl-consp duplicate-blocknames)
        (progn
          (dplm duplicate-blocknames "Duplicated block names : ")
          (setq inp (cfl (list "1 - I'm not gonna paste" "2 - Rename blocks before pasting"  "3 - I'm gonna paste anyway")))
          (cond
            ((or (void inp) (wcmatch inp "1*")) (alert "Copybase aborted"))
            ((wcmatch inp "2*")(foreach b duplicate-blocknames (rename_block_definition b))
             (princ "\nBlocks are renamed - select your basepoint now") (command "_copybase" pause ss ""))
            ((wcmatch inp "3*")
             (princ "\nBlock names unchanged - select your basepoint now")(command "_copybase" pause ss ""))
            (t (princ"\nBite me..."))
          )
        )
        (progn (princ "\nNo duplicate block names found - select your basepoint")(command "_copybase" pause ss ""))
      )
    )
  )
  (princ)
)

;;; get block names active doc - vanilla
(defun _bl ( / b l ) (while (setq b (tblnext "BLOCK" (null b)))
  (if (zerop (boole 1 21 (cdr (assoc 70 b)))) (setq l (cons (cdr (assoc 2 b)) l)))) l)

(defun Get_EX_Blocknames (other-dwg / fn l)
  (if (and (eq (type other-dwg) 'STR)(setq fn (findfile other-dwg))
           (setq doc (vla-open (vla-get-documents (vlax-get-acad-object)) fn)))
    (progn (setq l (GetDocBlockNames doc))(vla-close doc)(vlax-release-object doc))) l)

;;; test (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object))))
(defun GetDocBlockNames ( d / b n l) (vlax-for b (vla-get-blocks d)
  (if (and (= :vlax-false (vla-get-isxref b)) (= :vlax-false (vla-get-islayout b))
    (not (vl-string-search "*" (setq n (vla-get-name b)))))(setq l (cons n l)))) l)

(defun create_unique_blockname ( $bn / i bn)
  (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn)

(defun rename_block_definition ( $bn / bc bn )
  (setq bc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))))
  (if (and (not (void $bn)) (tblsearch "block" $bn))
    (vla-put-name (Collection-Member $bn bc)(setq bn (create_unique_blockname $bn)))) bn)

(defun compare_block_names (a b / c)
  (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c)

(defun Get_SS_BlockNames ( ss / n l)
  (foreach o (ss->ol ss)(if (and (setq n (block-n o))(not (member n l)))(setq l (cons n l)))) l)

(defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)

(defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x)))))

(defun block-n (o)(if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference"))
  (if (vlax-property-available-p o 'EffectiveName) (vla-Get-EffectiveName o) (vla-Get-Name o)) nil))

(defun Collection-Member (m c / r)
  (if (vl-catch-all-error-p (setq r (vl-catch-all-apply 'vla-item (list c m)))) nil r))
  
;;; display list (plus message)
(defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l))))
  (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";"
   "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb")
     (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f))))

;; choose from list (cfl '("1""2""3"))
(defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
 (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p)
  (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
   (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
    (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)")
     (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil)))

 

edit :

 

just had an idea , why not open the 'to be pasted' drawing after you made your selection.

 

Also tried if it was a bad thing if both drawings were already open and yes , that's  bad... but then I'm a bad bad dragon (it still opens but as read only)

 

Because I use vla-activate at the end , all lisp stops (obviously)

 

Once drawings is activated you can copypaste / ctrl-V yourself (I'm sure as hell not comming to do that for you  )

 

You decide what make you happy...

 

;;; check before paste 2 : after selection open the 'to be pasted' drawing - rlx 2025-10-22
(defun c:cbp2 ( / acDoc *docs* ss dbDoc blocknames-in-selectionset blocknames-in-dbDoc duplicate-blocknames inp do-it)
  (setq acDoc (vla-get-ActiveDocument (vlax-get-acad-object)) *docs* (vla-get-documents (vlax-get-acad-object)))
  (if (and (setq ss (ssget)) (setq dbDoc (getfiled "Drawing to check before you paste" "" "dwg" 0)))
    (progn
      (if (vl-consp (setq blocknames-in-selectionset (Get_SS_BlockNames ss)))
        (setq blocknames-in-selectionset (mapcar 'strcase blocknames-in-selectionset)))
      (if (vl-consp (setq blocknames-in-dbDoc (Get_EX_Blocknames dbDoc)))
        (setq blocknames-in-dbDoc (mapcar 'strcase blocknames-in-dbDoc)))
      (setq duplicate-blocknames (compare_block_names blocknames-in-selectionset blocknames-in-dbDoc))
      (if (vl-consp duplicate-blocknames)
        (progn
          (dplm duplicate-blocknames "Duplicated block names : ")
          (setq inp (cfl (list "1 - I'm not gonna paste" "2 - Rename blocks before pasting"  "3 - I'm gonna paste anyway")))
          (cond
            ((or (void inp) (wcmatch inp "1*")) (alert "Copybase aborted"))
            ((wcmatch inp "2*")(foreach b duplicate-blocknames (rename_block_definition b))
             (princ "\nBlocks are renamed - select your basepoint now")
             ;|(command "_copybase" pause ss "")|; (setq do-it t))
            ((wcmatch inp "3*")
             (princ "\nBlock names unchanged - select your basepoint now")
             ;|(command "_copybase" pause ss "")|; (setq do-it t))
            (t (princ"\nBite me..."))
          )
        )
        (progn
          (princ "\nNo duplicate block names found - select your basepoint")
          ;|(command "_copybase" pause ss "")|; (setq do-it t))
      )
    )
  )
  (if do-it (do_it))
)

(defun do_it ( / f d) (command "_copybase" pause ss "")(and (eq (type dbDoc) 'STR)
  (setq f (findfile dbDoc))(setq d (vla-open *docs* f)))(vla-activate d))
  

;;; get block names active doc - vanilla
(defun _bl ( / b l ) (while (setq b (tblnext "BLOCK" (null b)))
  (if (zerop (boole 1 21 (cdr (assoc 70 b)))) (setq l (cons (cdr (assoc 2 b)) l)))) l)

(defun Get_EX_Blocknames (dbDoc / fn l)
  (if (and (eq (type dbDoc) 'STR)(setq fn (findfile dbDoc))
           (setq doc (vla-open (vla-get-documents (vlax-get-acad-object)) fn)))
    (progn (setq l (GetDocBlockNames doc))(vla-close doc)(vlax-release-object doc))) l)

;;; test (setq lst (GetDocBlockNames (vla-get-ActiveDocument (vlax-get-acad-object))))
(defun GetDocBlockNames ( d / b n l) (vlax-for b (vla-get-blocks d)
  (if (and (= :vlax-false (vla-get-isxref b)) (= :vlax-false (vla-get-islayout b))
    (not (vl-string-search "*" (setq n (vla-get-name b)))))(setq l (cons n l)))) l)

(defun create_unique_blockname ( $bn / i bn)
  (setq i 0)(while (tblsearch "block" (setq bn (strcat $bn "_" (itoa (setq i (1+ i))))))) bn)

(defun rename_block_definition ( $bn / bc bn )
  (setq bc (vla-get-blocks (vla-get-ActiveDocument (vlax-get-acad-object))))
  (if (and (not (void $bn)) (tblsearch "block" $bn))
    (vla-put-name (Collection-Member $bn bc)(setq bn (create_unique_blockname $bn)))) bn)

(defun compare_block_names (a b / c)
  (and (vl-consp a) (vl-consp b) (foreach item a (if (member item b) (setq c (cons item c))))) c)

(defun Get_SS_BlockNames ( ss / n l)
  (foreach o (ss->ol ss)(if (and (setq n (block-n o))(not (member n l)))(setq l (cons n l)))) l)

(defun SS->OL (ss / i l)(setq i 0)(repeat (sslength ss)(setq l (cons (vlax-ename->vla-object (ssname ss i)) l) i (1+ i))) l)

(defun void (x) (or (eq x nil)(and (listp x)(not (vl-consp x)))(and (eq 'STR (type x))(eq "" (vl-string-trim " \t\r\n" x)))))

(defun block-n (o)(if (and (= 'vla-object (type O))(eq (vla-get-objectname O) "AcDbBlockReference"))
  (if (vlax-property-available-p o 'EffectiveName) (vla-Get-EffectiveName o) (vla-Get-Name o)) nil))

(defun Collection-Member (m c / r)
  (if (vl-catch-all-error-p (setq r (vl-catch-all-apply 'vla-item (list c m)))) nil r))
  
;;; display list (plus message)
(defun dplm (l m / f p d w) (and (vl-consp l) (setq l (mapcar 'vl-princ-to-string l)) (setq w (+ 5 (apply 'max (mapcar 'strlen l))))
  (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w")) (princ (strcat "cfl:dialog{label=\"" m "\";:list_box {key=\"lb\";"
   "width="(itoa w)";}ok_only;}") p)(not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)(progn (start_list "lb")
     (mapcar 'add_list l)(end_list)(action_tile "accept" "(done_dialog)")(start_dialog)(unload_dialog d)(vl-file-delete f))))

;; choose from list (cfl '("1""2""3"))
(defun cfl (l / f p d r) (and (setq p (open (setq f (vl-filename-mktemp ".dcl")) "w"))
 (princ "cfl:dialog{label=\"Choose\";:list_box{key=\"lb\";width=40;}ok_cancel;}" p)
  (not (setq p (close p)))(< 0 (setq d (load_dialog f)))(new_dialog "cfl" d)
   (progn (start_list "lb")(mapcar 'add_list l)(end_list)(action_tile "lb" "(setq r (nth (atoi $value) l))(done_dialog 1)")
    (action_tile "accept" "(setq r (get_tile \"lb\"))(done_dialog 1)")(action_tile "cancel" "(setq r nil)(done_dialog 0)")
     (start_dialog)(unload_dialog d)(vl-file-delete f))) (cond ((= r "") nil)(r r)(t nil)))

 

Edited 2 hours ago by rlx