[LISP程序]：复选修正图块名称

xyz518mm

引用
作者：highflybir  
來源：http://www.mjtd.com/Codes/ArticleShow.asp?ArticleID=1191
程序


[PHP]
;;;改块名程序
(DEFUN change-block-name (EntNam NewNam / obj blocks BlkNam block)
(SETQ obj (VLAX-ENAME->VLA-OBJECT EntNam))
(SETQ blocks (VLA-GET-BLOCKS *DOC))
(IF (= (VLA-GET-OBJECTNAME obj) "AcDbBlockReference")
  (IF (TBLSEARCH "block" NewNam)
   (PROGN
    (PRINC "\n 和现有图块名重复!")
    (IF
     (= (SETQ KEY (KEY_NAME_YN "CHANG_BLACK_YN" "是否更换图块名!"))
        "Y"
     )
     (PROGN
      (SETQ BlkNam (VLA-GET-NAME obj))
      (SETQ block (VLA-ITEM blocks BlkNam))
      (VLA-PUT-NAME block NewNam)
      (IF (= (SUBSTR BlkNam 1 2) "*U")
       (PROGN
        (PRINC "\n这是一个匿名块")
        (VLA-AUDITINFO *Doc :VLAX-TRUE)
        (VLA-PUT-NAME block NewNam)
       )
      )
      (PRINC "\n块名已经更改成\"")
      (PRINC NewNam)
      (PRINC "\"")
     )
    )
   )
   (PROGN
    (SETQ BlkNam (VLA-GET-NAME obj))
    (SETQ block (VLA-ITEM blocks BlkNam))
    (VLA-PUT-NAME block NewNam)
    (IF (= (SUBSTR BlkNam 1 2) "*U")
     (PROGN
      (PRINC "\n这是一个匿名块")
      (VLA-AUDITINFO *Doc :VLAX-TRUE)
      (VLA-PUT-NAME block NewNam)
     )
    )
    (PRINC "\n块名已经更改成\"")
    (PRINC NewNam)
    (PRINC "\"")
   )
  )
  (PRINC "\n所选物体不是块!")
)
)

(defun c:LOK ( /  entnam i newnam ss)
(prompt "\n**<用途:更新图块名称.1>**")
(vl-load-com)
(setq *APP (vlax-get-acad-object))
(setq *DOC (vla-get-activeDocument *APP))
(SETQ NewNam (GETSTRING "\n请输入新块名:"))
(setq ss (ssget '((0 . "INSERT"))))
(SETQ i 0)
(REPEAT        (SSLENGTH ss)
(SETQ EntNam (SSNAME ss i))
(change-block-name EntNam NewNam)
(SETQ i (1+ I))
)
(prin1))

[/PHP]
使用命令 LOK

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

建议你引用时注明来源。

xyz518mm

不好意思下次会改进注明来源