求修改某大师的改块名代码。。谢谢
;;;修改块名(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)
)
明经下载的忘了出自哪位大师之手了~
本功能在更改块名的时候，手动输入重命名的块名称。。
增加个功能直接图中选择单行文字作为重命名的块名。。。。免得手工再去输入。
谢谢哪位大师能出手帮忙谢谢~~ 改了一下，可以输入也可以选择。如果无选择那么要求输入块名称
(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)
) 看到了给你一个简单的。
(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)
) 加一个已存在提示，重复后停止执行。
(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)
) 我也发一个以前搜集的，不知道能不能帮到你 ;;;;;改块名程序
(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所选物体不是块!")
)
) 最好提示能显示原来的块名~~~~~~~~~~~~~~~~~~~ 原块名在“[]”中显示
(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)
) 路过，学习一下 楼主能不能只改图中同名的部分图块的图名，其余的相同的图块名字不变？
页:
[1]
2