求修改某大师的改块名代码。。谢谢

flytoday · 发表于 2013-5-22 03:22:30

;;;修改块名
(defun c:XGGM (/ ent name name1 dclname tempname filen stream dcl_re dlg new)
  (if (and (setq ent (car (entsel "\n选择需要改名的块: "))) (or (eq "INSERT" (cdr (assoc 0 (entget ent)))) (alert "没有选择块!")))
(progn
   (setq name (cdr (assoc 2 (entget ent))))
(setq dclname
  (cond
(
   (setq tempname (vl-filename-mktemp "re-dcl-tmp.dcl") filen (open tempname "w"))
   (foreach stream '(
"\n"
"RENAME:dialog {\n"
" label = \"修改块名\" ;\n"
" :row {\n"
"       :edit_box {\n"
"          key = \"dcl_edit_name\" ;\n"
"          width = 30 ;\n"
"       }\n"
" }\n"
" :row {\n"
"       :button {\n"
"          key = \"btn_ok\" ;\n"
"          label = \"确认\" ;\n"
"       }\n"
"       :button {\n"
"          is_cancel = true ;\n"
"          key = \"btn_cancle\" ;\n"
"          label = \"取消\" ;\n"
"       }\n"
" }\n"
"}\n"
   )
   (princ stream filen)
   )
   (close filen)
   tempname
)
  )
)
   (setq dcl_re (load_dialog dclname))
   (if (not (new_dialog "RENAME" dcl_re)) (exit))
   (set_tile "dcl_edit_name" name)
   (mode_tile "dcl_edit_name" 2)
   (action_tile "dcl_edit_name" "(setq name1 $value)")
   (action_tile "btn_ok" "(if (tblsearch \"block\" name1)
                           (alert (strcat \"块名: \" name1 \" 已经存在.\"))
                           (if (not (snvalid name1))
                              (alert (strcat \"错误的块名: \" name1))
                              (done_dialog 1)
                           )
                           )"
   )
   (setq dlg (start_dialog))
   (if (= dlg 1)
      (progn
      (command "_.rename" "_block" name name1)
      (princ (strcat "\n图块 \"" name "\" 重命名为 \"" name1 "\""))
      )
   )
   (unload_dialog dcl_re)
   (vl-file-delete dclname)
)
  )
  (princ)
)
明经下载的忘了出自哪位大师之手了~
本功能在更改块名的时候，手动输入重命名的块名称。。
增加个功能直接图中选择单行文字作为重命名的块名。。。。免得手工再去输入。
谢谢哪位大师能出手帮忙谢谢~~

wszxf · 发表于 2013-5-22 03:22:31

改了一下，可以输入也可以选择。如果无选择那么要求输入块名称
(defun c:gkm (/ NAME NEW-NAME)
  (setq name (Vlax-Get (Vlax-Ename->Vla-Object
   (car (entsel "\n选择要改块名的块："))
         )
         'Name
      )
  )
  (setq ss-text (entsel "\n选择新块名称文字:"))
  (if (= ss-text nil)
(setq new-name (getstring "\输入新的块名:"))
(setq new-name (Vlax-Get (Vlax-Ename->Vla-Object
         (car ss-text)
      )
      'TextString
   )
)
  )
  (command "_.rename" "_block" name new-name)
  (princ)
)

wszxf · 发表于 2013-5-22 08:06:35

看到了给你一个简单的。
(defun c:gkm (/ NAME NEW-NAME)
  (setq name (Vlax-Get (Vlax-Ename->Vla-Object (car (entsel))) 'Name))
  (setq new-name (Vlax-Get (Vlax-Ename->Vla-Object
      (car (entsel "选择新块名称文字："))
   )
   'TextString
   )
  )
  (command "_.rename" "_block" name new-name)
)

wszxf · 发表于 2013-5-22 08:15:52

加一个已存在提示，重复后停止执行。
(defun c:gkm (/ NAME NEW-NAME)
  (setq name (Vlax-Get (Vlax-Ename->Vla-Object
   (car (entsel "\n选择要改块名的块："))
         )
         'Name
      )
  )
  (setq ss-text (entsel "\n选择新块名称文字:"))
  (if (= ss-text nil)
(setq new-name (getstring "\输入新的块名:"))
(setq new-name (Vlax-Get (Vlax-Ename->Vla-Object
         (car ss-text)
      )
      'TextString
   )
)
  )
  (if (tblsearch "block" new-name)
(princ (strcat "\n新块名" new-name "已经存在请重试!"))
(command "_.rename" "_block" name new-name)
  )
  (princ)
)

ucuc2003 · 发表于 2013-5-22 10:05:31

我也发一个以前搜集的，不知道能不能帮到你

ucuc2003 · 发表于 2013-5-22 10:09:39

;;;;;改块名程序
(defun C:km (/ *APP *DOC EntNam NewNam)
(vl-load-com)
(setq *APP (vlax-get-acad-object))
(setq *DOC (vla-get-activeDocument *APP))
(if (setq EntNam (car (entsel "\n请选择块: ")))
   (if (setq NewNam (getstring "\n请输入新块名<字符规范,不要重名>: "))
      (change-block-name EntNam NewNam)
      (princ "\n你没有输入新块名!")
   )
   (princ "\n你没有选择物体!")
)
(princ)
)
;;;改块名程序
(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)
      (princ "\n和已有块名重复!")
      (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所选物体不是块!")
)
)

flytoday · 发表于 2013-5-22 12:47:44

最好提示能显示原来的块名~~~~~~~~~~~~~~~~~~~

wszxf · 发表于 2013-5-22 13:10:08

原块名在“[  ]”中显示
(defun c:gkm (/ NAME NEW-NAME)
  (setq name (Vlax-Get (Vlax-Ename->Vla-Object
   (car (entsel "\n选择要改块名的块："))
         )
         'Name
      )
  )

  (setq ss-text (entsel (strcat "\n选择新块名称文字[" name "]:")))
  (if (= ss-text nil)
(setq new-name (getstring (strcat "\输入新的块名[" name "]:")))
(setq new-name (Vlax-Get (Vlax-Ename->Vla-Object
         (car ss-text)
      )
      'TextString
   )
)
  )
  (if (tblsearch "block" new-name)
(princ (strcat "\n新块名" new-name "已经存在请重试!"))
(command "_.rename" "_block" name new-name)
  )
  (princ)
)

陈亚娣 · 发表于 2013-6-25 17:11:35

路过，学习一下

bai2000 · 发表于 2013-6-28 19:58:30

楼主能不能只改图中同名的部分图块的图名，其余的相同的图块名字不变？

账号		自动登录	找回密码
密码			注册

[公告] 求修改某大师的改块名代码。。谢谢

最佳答案

相关帖子

评分

评分

点评