aeo 发表于 2004-2-25 00:12:52

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


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




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

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

陌生人 发表于 2004-2-25 02:16:56

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

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

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

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

Command:
Command:
Command: es LIST 1 found

                  BLOCK REFERENCELayer: "0"
                            Space: Model space
                   Handle = 99
                  "1"    （块名没变？）
                at point, X=    30831Y=    12778Z=      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 发表于 2016-8-23 09:20:59

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

yoyoho 发表于 2016-10-28 08:00:19

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

jdzhqddzh 发表于 2026-2-14 15:56:04

这个东西真心不错，可以改块的名称了。
页: [1]
查看完整版本: [分享]："图块改名" 和"图块单独改名"