[分享]："图块改名" 和"图块单独改名"

aeo

2. 
   
3. ;;;=======================
   
4. ;;;图块改名.
   
5. ;;;无名块改名后，再改出错.
   
6. ;;;By Aeo
   
7. ;;;-----------------------
   
8. (defun C:TTt ( / blk blkref blocks doc new-blk new-name old-blk old-name)
   
9.   (vl-load-com)
   
10.   (if(and (setq BLK     (car (entsel "\n选要改名的块: ")))
    
11.           (setq BLKREF  (vlax-ename->vla-object BLK))
    
12.           (= (vla-get-objectname BLKREF) "AcDbBlockReference")
    
13.           (setq old-name(vla-get-name BLKREF))
    
14.           (/= ""(setq new-name(getstring (strcat"\n新名称(" old-name "): "))))
    
15.           (not(and(= new-name "*")(princ"\n名称可以为*加任意字母")))
    
16.           (not(and(tblsearch "block"new-name)(princ"\n图块已存在.")))
    
17.       )
    
18.       (progn
    
19.           (command"undo""group")
    
20.           (setq DOC     (vla-get-activedocument (vlax-get-acad-object))
    
21.                 BLOCKS  (vla-get-blocks doc)
    
22.                 old-blk (vla-item BLOCKS old-name)
    
23.           )
    
24.           (vla-put-name old-blk new-name)
    
25.         (if(wcmatch old-name "`**")
    
26.           (progn
    
27.            (setq new-BLK (vla-add BLOCKS (vla-get-origin old-blk)new-name))
    
28.            (vlax-for ENT old-blk
    
29.              (vla-copyobjects  DOC
    
30.                 (vlax-safearray-fill
    
31.                   (vlax-make-safearray vlax-vbobject '(0 . 0))
    
32.                   (list ENT)
    
33.                 )
    
34.                 new-BLK
    
35.             ))
    
36.            (vlax-release-object new-BLK)
    
37.            )
    
38.          )
    
39.         (vlax-release-object old-blk)
    
40.         (vlax-release-object BLOCKS)
    
41.         (vlax-release-object DOC)
    
42.         (command"undo""end")
    
43.      )
    
44.   )
    
45.   (prin1)
    
46. )
    
47. 
    

<br /> ;;;=======================<br /> ;;;图块改名.<br /> ;;;无名块改名后，再改出错.<br /> ;;;By Aeo<br /> ;;;-----------------------<br /> (defun C:TTt ( / blk blkref blocks doc new-blk new-name old-blk old-name)<br />   (vl-load-com)<br />   (if(and (setq BLK     (car (entsel "\n选要改名的块: ")))<br />           (setq BLKREF  (vlax-ename->vla-object BLK))<br />           (= (vla-get-objectname BLKREF) "AcDbBlockReference")<br />           (setq old-name(vla-get-name BLKREF))<br />           (/= ""(setq new-name(getstring (strcat"\n新名称(" old-name "): "))))<br />           (not(and(= new-name "*")(princ"\n名称可以为*加任意字母")))<br />           (not(and(tblsearch "block"new-name)(princ"\n图块已存在.")))<br />       )<br />       (progn<br />           (command"undo""group")<br />           (setq DOC     (vla-get-activedocument (vlax-get-acad-object))<br />                 BLOCKS  (vla-get-blocks doc)<br />                 old-blk (vla-item BLOCKS old-name)<br />           )<br />           (vla-put-name old-blk new-name)<br />         (if(wcmatch old-name "`**")<br />           (progn<br />            (setq new-BLK (vla-add BLOCKS (vla-get-origin old-blk)new-name))<br />            (vlax-for ENT old-blk<br />              (vla-copyobjects  DOC<br />                 (vlax-safearray-fill<br />                   (vlax-make-safearray vlax-vbobject '(0 . 0))<br />                   (list ENT)<br />                 )<br />                 new-BLK<br />             ))<br />            (vlax-release-object new-BLK)<br />            )<br />          )<br />         (vlax-release-object old-blk)<br />         (vlax-release-object BLOCKS)<br />         (vlax-release-object DOC)<br />         (command"undo""end")<br />      )<br />   )<br />   (prin1)<br /> )<br /> <br />

临时想把块中的一个换个名称:

2. 
   
3. ;;;=======================
   
4. ;;;图块改名拷贝,点到的那个块改成新名称，
   
5. ;;;但其他同名块不变.
   
6. ;;;By Aeo
   
7. ;;;-----------------------
   
8. (defun C:TT ( / blk blkref blocks doc new-blk new-name old-blk old-name)
   
9.   (vl-load-com)
   
10.   (if(and (setq BLK     (car (entsel "\n选要改名的块: ")))
    
11.           (setq BLKREF  (vlax-ename->vla-object BLK))
    
12.           (= (vla-get-objectname BLKREF) "AcDbBlockReference")
    
13.           (setq old-name(vla-get-name BLKREF))
    
14.           (/= ""(setq new-name(getstring (strcat"\n新名称(" old-name "): "))))
    
15.           (not(and(= new-name "*")(princ"\n名称可以为*加任意字母,变为匿名块")))
    
16.           (not(and(tblsearch "block"new-name)(princ"\n图块已存在.")))
    
17.       )
    
18.       (progn
    
19.           (command"undo""group")
    
20.           (setq DOC     (vla-get-activedocument (vlax-get-acad-object))
    
21.                 BLOCKS  (vla-get-blocks doc)
    
22.                 old-blk (vla-item BLOCKS old-name)
    
23.           )
    
24.            (setq new-BLK (vla-add BLOCKS (vla-get-origin old-blk)new-name))
    
25.            (vlax-for ENT old-blk
    
26.              (vla-copyobjects  DOC
    
27.                 (vlax-safearray-fill
    
28.                   (vlax-make-safearray vlax-vbobject '(0 . 0))
    
29.                   (list ENT)
    
30.                 )
    
31.                 new-BLK
    
32.             ))
    
33.         (vla-put-name BLKREF new-name)
    
34.         (vlax-release-object new-BLK)
    
35.         (vlax-release-object old-blk)
    
36.         (vlax-release-object BLOCKS)
    
37.         (vlax-release-object DOC)
    
38.         (command"undo""end")
    
39.      )
    
40.   )
    
41.   (prin1)
    
42. )
    

<br /> ;;;=======================<br /> ;;;图块改名拷贝,点到的那个块改成新名称，<br /> ;;;但其他同名块不变.<br /> ;;;By Aeo<br /> ;;;-----------------------<br /> (defun C:TT ( / blk blkref blocks doc new-blk new-name old-blk old-name)<br />   (vl-load-com)<br />   (if(and (setq BLK     (car (entsel "\n选要改名的块: ")))<br />           (setq BLKREF  (vlax-ename->vla-object BLK))<br />           (= (vla-get-objectname BLKREF) "AcDbBlockReference")<br />           (setq old-name(vla-get-name BLKREF))<br />           (/= ""(setq new-name(getstring (strcat"\n新名称(" old-name "): "))))<br />           (not(and(= new-name "*")(princ"\n名称可以为*加任意字母,变为匿名块")))<br />           (not(and(tblsearch "block"new-name)(princ"\n图块已存在.")))<br />       )<br />       (progn<br />           (command"undo""group")<br />           (setq DOC     (vla-get-activedocument (vlax-get-acad-object))<br />                 BLOCKS  (vla-get-blocks doc)<br />                 old-blk (vla-item BLOCKS old-name)<br />           )<br />            (setq new-BLK (vla-add BLOCKS (vla-get-origin old-blk)new-name))<br />            (vlax-for ENT old-blk<br />              (vla-copyobjects  DOC<br />                 (vlax-safearray-fill<br />                   (vlax-make-safearray vlax-vbobject '(0 . 0))<br />                   (list ENT)<br />                 )<br />                 new-BLK<br />             ))<br />         (vla-put-name BLKREF new-name)<br />         (vlax-release-object new-BLK)<br />         (vlax-release-object old-blk)<br />         (vlax-release-object BLOCKS)<br />         (vlax-release-object DOC)<br />         (command"undo""end")<br />      )<br />   )<br />   (prin1)<br /> )<br />

陌生人

“无名块改名后，再改出错.”
能说说具体测试的情形么？查到原因否？想到解决的办法否？

测试，好像做匿名块还有点问题，是我弄错了么？
另外，建议可做匿名块的提示放到前面去，命名完了才显示，有点晚了。

Command:  TT
选要改名的块:
新名称(1): *

名称可以为*加任意字母,变为匿名块

Command:
Command:
Command: es LIST 1 found

                  BLOCK REFERENCE  Layer: "0"
                            Space: Model space
                   Handle = 99
                  "1"    （块名没变？）
                at point, X=    30831  Y=    12778  Z=        0
                 X scale factor         1
                 Y scale factor         1
          rotation angle      0
                 Z scale factor         1

Command: tt
选要改名的块:
新名称(1): *U

错误: Automation 错误。 Key not found

Command: tt
选要改名的块:
新名称(1): *1

错误: Automation 错误。 调用方法 SetObjectId 的界面 IAcadBaseObject 失败

Command:
TT
选要改名的块:
新名称(1): *a

错误: Automation 错误。 Key not found

qq1254582201

这个东西真心不错，可以改块的名称了。。。

yoyoho

正需要，支持 aeo 楼主大人了！