[LISP程序]：快速重新命名块

brainstorm

(defun zgx-get-dxf (code entname kk)
   (if (= kk 2)
      (assoc code (entget entname))
      (cdr (assoc code (entget entname)))
   )
)
(defun c:renblk        (/ en newname oldname)
   (setvar "cmdecho" 0)
   (while (or (= nil en)
              (if en
                 (/= (zgx-get-dxf 0 en 1) "INSERT")
              )
          )
      (setq en (car (entsel "\n请选择要重名的图块:")))
   )
   (setq oldname (zgx-get-dxf 2 en 1))
   (while (or (= newname nil)
              (= newname "")
              (if newname
                 (tblsearch "block" newname)
              )
          )
      (setq newname
              (getstring (strcat "\n请输入新的块名称,[选择的块名为:"
                                 oldname
                                 "]:"
                         )
              )
      )
   )
   (command ".rename" "b" oldname newname)
   (princ
      (strcat "\n*****图块" oldname "重命名为" newname "!*****")
   )
   (princ)
)

haibinpro

不支持重命名无名块。。。

egos

不支持重命名无名块就没什么应用价值 CAD本身又有重命名块的功能

highflybird

关于对无名块的改名可见：
http://www.mjtd.com/Codes/ArticleShow.asp?ArticleID=1191

2. 
   
3. (prompt "在命令行中输入命令: CCC!")
   
4. ;;;测试程序
   
5. (defun C:ccc (/ *APP *DOC EntNam NewNam i l)
   
6.   (vl-load-com)
   
7.   (setq *APP (vlax-get-acad-object))
   
8.   (setq *DOC (vla-get-activeDocument *APP))
   
9.   ;;(vla-auditinfo *Doc :vlax-true)
   
10.   (prompt "\n请选择块: ")
    
11.   (if (setq SS (ssget '((0 . "INSERT"))))
    
12.     (progn
    
13.       (setq l (sslength ss))
    
14.       (setq i 0)
    
15.       (while (< i l)
    
16.         (setq EntNam (ssname ss i))
    
17.         (if (setq NewNam (getstring "\n请输入新块名<字符规范,不要重名>: "))
    
18.           (change-block-name EntNam NewNam)
    
19.           (princ "\n你没有输入新块名!")
    
20.         )
    
21.         (setq i (1+ i))
    
22.       )
    
23.     )
    
24.     (princ "\n你没有选择块物体!")
    
25.   )  
    
26.   (princ)
    
27. )
    
28. ;;;改块名程序
    
29. (defun change-block-name (EntNam NewNam / obj blocks BlkNam block)
    
30.   (setq obj (vlax-ename->vla-object EntNam))
    
31.   (setq blocks (vla-get-blocks *DOC))
    
32.   (if (=(vla-get-objectname obj) "AcDbBlockReference")
    
33.     (if (tblsearch "block" NewNam)
    
34.       (princ "\n和已有块名重复!")
    
35.       (progn
    
36.         (setq BlkNam (vla-get-name obj))
    
37.         (setq block  (vla-item blocks BlkNam))
    
38.         (vla-put-name block NewNam)
    
39.         (if (= (substr BlkNam 1 1) "*")
    
40.           (progn
    
41.             (princ "\n这是一个匿名块.")
    
42.             (vla-auditinfo *Doc :vlax-true)
    
43.             (vla-put-name block NewNam)
    
44.           )
    
45.         )
    
46.         (princ "\n块名已经更改成"")
    
47.         (princ NewNam)
    
48.         (princ """)
    
49.       )
    
50.     )
    
51.     (princ "\n所选物体不是块!")
    
52.   )
    
53. )
    

<br /> (prompt "在命令行中输入命令: CCC!")<br /> ;;;测试程序<br /> (defun C:ccc (/ *APP *DOC EntNam NewNam i l)<br />   (vl-load-com)<br />   (setq *APP (vlax-get-acad-object))<br />   (setq *DOC (vla-get-activeDocument *APP))<br />   ;;(vla-auditinfo *Doc :vlax-true)<br />   (prompt "\n请选择块: ")<br />   (if (setq SS (ssget '((0 . "INSERT"))))<br />     (progn <br />       (setq l (sslength ss))<br />       (setq i 0)<br />       (while (< i l)<br />         (setq EntNam (ssname ss i))<br />         (if (setq NewNam (getstring "\n请输入新块名<字符规范,不要重名>: "))<br />           (change-block-name EntNam NewNam)<br />           (princ "\n你没有输入新块名!")<br />         )<br />         (setq i (1+ i))<br />       )<br />     )<br />     (princ "\n你没有选择块物体!") <br />   )  <br />   (princ)<br /> )<br /> ;;;改块名程序<br /> (defun change-block-name (EntNam NewNam / obj blocks BlkNam block)<br />   (setq obj (vlax-ename->vla-object EntNam))<br />   (setq blocks (vla-get-blocks *DOC)) <br />   (if (=(vla-get-objectname obj) "AcDbBlockReference")<br />     (if (tblsearch "block" NewNam)<br />       (princ "\n和已有块名重复!")<br />       (progn<br />         (setq BlkNam (vla-get-name obj))<br />         (setq block  (vla-item blocks BlkNam))<br />         (vla-put-name block NewNam)<br />         (if (= (substr BlkNam 1 1) "*") <br />           (progn <br />             (princ "\n这是一个匿名块.")<br />             (vla-auditinfo *Doc :vlax-true)<br />             (vla-put-name block NewNam)<br />           )<br />         )<br />         (princ "\n块名已经更改成"")<br />         (princ NewNam)<br />         (princ """)<br />       )<br />     )<br />     (princ "\n所选物体不是块!")<br />   )<br /> )<br />