[编程交流] 块替换名称lisp

(defun c:REP (/ ENT1 BL1 bl2 OLD ODNM)
(command "undo" "begin")
(prompt "\nSelect Replacement Block: ")
(setq bl2 (cdr (assoc 2 (entget (car (entsel))))))
(prompt "Select blocks to replace: ")
(setq ENT1 (ssget))
(setq N (sslength ENT1))
(setq I 0)
(repeat N
 (setq BL1 (entget (ssname ENT1 I)))
 (setq NWNM (cons 2 bl2))  
 (setq OLD (assoc 2 BL1))  
 (setq ODNM (cdr OLD))  
 (entmod (subst NWNM OLD BL1))
 (setq I (1+ I))
)
(command "undo" "end")
(princ)
) 

(defun c:REPT (/ ENT1 BL1 bl2 OLD ODNM)
(command "undo" "begin")
(setq bl2 (getstring "\nType a new name: "))
(prompt "Select blocks to replace: ")
(setq ENT1 (ssget))
(setq N (sslength ENT1))
(setq I 0)
(repeat N
 (setq BL1 (entget (ssname ENT1 I)))
 (setq NWNM (cons 2 bl2))  
 (setq OLD (assoc 2 BL1))  
 (setq ODNM (cdr OLD))  
 (entmod (subst NWNM OLD BL1))  (princ NWNM) (princ old)
 (setq I (1+ I))
)
(command "undo" "end")
(princ)
) 

(defun c:renblref ( / ss n k bl blnl p )
 (vl-load-com)
 (setq n "")
 (while (not (snvalid n))
   (setq n (getstring t "\nSpecify new block reference name: "))
 )
 (prompt "\nSelect block references to rename")
 (setq ss (ssget ":L" '((0 . "INSERT"))))
 (setq k -1)
 (while (setq bl (ssname ss (setq k (1+ k))))
   (setq blnl (cons (vl-remove-if-not '(lambda ( x ) (member (car x) '(8 2 41 42 43 50 210))) (entget bl)) blnl))
 )
 (if (not (vl-every '(lambda (x) (equal x (car blnl))) blnl))
   (progn
     (alert "Selected block references with different layers, or names, or scale factors, or rotations, or normals - quitting... Select only unique block references...")
     (exit)
   )
   (progn
     (setq k -1)
     (while (setq bl (ssname ss (setq k (1+ k))))
       (setq p (cdr (assoc 10 (entget bl))))
       (setq p (trans p 0 1))
       (if (eq k 0)
         (progn
           (command "_.explode" bl)
           (while (> (getvar 'cmdactive) 0) (command ""))
           (command "_.copybase" p (ssget "_P") "")
           (command "_.pasteblock" p)
           (command "_.erase" (ssget "_P") "")
           (vla-put-name
             (vla-item (vla-get-blocks
                         (vla-get-activedocument (vlax-get-acad-object))
                       )
                       (vla-get-name (vlax-ename->vla-object (entlast)))
             )
             n
           )
           (vla-auditinfo
             (vla-get-activedocument (vlax-get-acad-object))
             :vlax-true
           )
           (vla-put-name
             (vla-item (vla-get-blocks
                         (vla-get-activedocument (vlax-get-acad-object))
                       )
                       (vla-get-name (vlax-ename->vla-object (entlast)))
             )
             n
           )
         )
         (progn
           (command "_.erase" bl "")
           (command "_.insert" n p 1 1 0)
         )
       )
     )
   )
 )
 (princ)
)