[原创]一个块替换程序
;;; =================================================================;;; 块替换；选择源块A，然后选择需要替换成块A的块B，再选择一个区域，然后把这个区域里的块B换成块A
;;; 作者：langjs 命令：KTH 日期2011年3月22日
;;; =================================================================
(defun C:KTH (/ ent ent1 ent2 i kming1 kming2 lst name1 name2 pt ss)
(setvar "cmdecho" 0) ; 关闭命令响应
(setq $orr *error*)
(setq *error* #err2) ; 当程序出错时就会执行#err函数
(command ".UNDO" "BE") ; 设置UNDO起点
(setq t 1)
(while (= t 1)
(setq name1 (car (entsel "\n选择源块A：")))
(setq ent1 (entget name1))
(if (= (cdr (assoc 0 ent1)) "INSERT")
(progn
(setq kming1 (cdr (assoc 2 ent1)))
(redraw name1 3)
(setq t 2)
)
(princ "\n选择源块A：")
)
)
(while (= t 2)
(setq name2 (car (entsel "\n选择替换块B：")))
(setq ent2 (entget name2))
(if (= (cdr (assoc 0 ent2)) "INSERT")
(progn
(setq kming2 (cdr (assoc 2 ent2)))
(redraw name2 3)
(setq t 3)
)
(princ "\n选择替换块B：")
)
)
(while (= t 3)
(prompt "\n选择替换区域:")
(setvar "nomutt" 1)
(setq ss (ssget (list (cons 2 kming2))))
(setvar "nomutt" 0)
(if ss
(setq t 4)
)
)
(redraw name1 4)
(redraw name2 4)
(setq lst '())
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq ent (entget ent))
(setq lst (cons (cdr (assoc 10 ent)) lst))
)
(command "erase" ss "") ; 删除块
(setq i 0)
(while (< i (length lst))
(setq PT (nth i lst))
(command "INSERT" kming1 PT 1 1 0) ; 插入块，
(nth i lst)
(setq i (+ i 1))
)
(command ".UNDO" "E") ; 设置UNDO终点
(setq *error* $orr)
(princ)
)
;;; 出错处理函数
(defun #err2 (s)
(command ".UNDO" "E") ; 设置UNDO终点
(redraw name1 4)
(redraw name2 4)
(princ)
(setq *error* $orr)
)
本帖最后由 lidaxiu 于 2011-12-30 17:41 编辑
楼主的程序有欠缺，没有计算替换后的块比例 ;; =================================================================
;;; 块替换；选择源块A，然后选择需要替换成块A的块B，再选择一个区域，然后把这个区域里的块B换成块A
;;; 作者：langjs 命令：KTH 日期2011年3月22日
;;; =================================================================
(defun C:KTH (/ ent ent1 ent2 i kming1 kming2 lst name1 name2 pt ss t1)
(setvar "cmdecho" 0) ; 关闭命令响应
(setq $orr *error*)
(setq *error* #err2) ; 当程序出错时就会执行#err函数
(command ".UNDO" "BE") ; 设置UNDO起点
(setq t1 1)
(while (= t1 1)
(setq name1 (car (entsel "\n选择源块A：")))
(setq ent1 (entget name1))
(if (= (cdr (assoc 0 ent1)) "INSERT")
(progn
(setq kming1 (cdr (assoc 2 ent1)))
(redraw name1 3)
(setq t1 2)
)
(princ "\n选择源块A：")
)
)
(while (= t1 2)
(setq name2 (car (entsel "\n选择替换块B：")))
(setq ent2 (entget name2))
(if (= (cdr (assoc 0 ent2)) "INSERT")
(progn
(setq kming2 (cdr (assoc 2 ent2)))
(redraw name2 3)
(setq t1 3)
)
(princ "\n选择替换块B：")
)
)
(while (= t1 3)
(prompt "\n选择替换区域:")
(setvar "nomutt" 1)
(setq ss (ssget (list (cons 2 kming2))))
(setvar "nomutt" 0)
(if ss
(setq t1 4)
)
)
(redraw name1 4)
(redraw name2 4)
(setq lst '())
(repeat (setq i (sslength ss))
(setq ent (ssname ss (setq i (1- i))))
(setq ent (entget ent))
(setq lst (cons (cdr (assoc 10 ent)) lst))
)
(command "erase" ss "") ; 删除块
(setq i 0)
(while (< i (length lst))
(setq PT (nth i lst))
(command "INSERT" kming1 PT 1 1 0) ; 插入块，
(nth i lst)
(setq i (+ i 1))
)
(command ".UNDO" "E") ; 设置UNDO终点
(setq *error* $orr)
(princ)
)
;;; 出错处理函数
(defun #err2 (s)
(command ".UNDO" "E") ; 设置UNDO终点
(redraw name1 4)
(redraw name2 4)
(princ)
(setq *error* $orr)
)
T改T1 行吗 大神
狼大哥 6666666666666666666666666666666666666666666666666666666666666666666666666 正要找这个东东，谢谢楼主。 能不能加上可能输入块名，这样可以加上不是图中有的块。哪位出下手改一改 感谢楼主分享源码程序 <谢谢!> @langjs :测试之后发现块B消失,块A依然还是原样...这是什么原因?
本帖最后由 mandala 于 2011-4-16 10:36 编辑
这类程序编起来难度不大，但非常实用，可以用来替换符号等等。
我觉得选择区域这段可能利用率不高，会影响程序效率。不如直接改成选择整幅图纸。
另外除了替换块，可以考虑把替换形也加进去，反正只要加一句话就可以。很多符号都是形，而不是块。
最后替换的块，最好以输入块名实现。在实际操作中，恐怕图纸上未必会有要替换的块。
但这类程序真要编得完美也很难。比如，有的块已经被打散。 本帖最后由 mandala 于 2011-4-16 10:47 编辑
CAD83 发表于 2011-3-27 19:11 http://bbs.mjtd.com/static/image/common/back.gif
能不能加上可能输入块名，这样可以加上不是图中有的块。哪位出下手改一改
这个lsp是我写来替换图纸中的符号的，采用的也是框选而非全局替换。程序思路跟楼主差不多，你可以参考一下。
;;将原有的由块或形构成的符号，替换成指定的符号
(defun c:fh (/ *error* lay os x ss i ents pt)
(defun *error* (msg)
(print msg)
(setvar "clayer" lay)(setvar "osmode" os)
(command "._undo" "_e")
) ;_ 结束defun
(prompt "\n将原有的块或形符号替换成指定的符号：")
(command "._undo" "_be")
(setvar "cmdecho" 0)
(setq lay (getvar "clayer"))
;(setvar "clayer" "fuhao")
(setq os (getvar "osmode"))
(setvar "osmode" 0)
(setq x (getstring "\n请输入新的符号编码："))
(prompt "\n请选择你想替换的符号：")
(setq ss (ssget '((0 . "insert,shape"))))
(while ss
(setq i 0)
(repeat (sslength ss)
(setq ents (entget (ssname ss i)))
(setq pt (cdr(assoc 10 ents)))
(command "shape" x pt "1" "0")
(entdel (ssname ss i))
(setq i (1+ i))
) ;_ 结束repeat
(setq ss (ssget '((0 . "insert,shape"))))
) ;_ 结束while
(setvar "clayer" lay)(setvar "osmode" os)
(command "._undo" "_e")
(princ)
) ;_ 结束defun
这个程序好，下下来备着 备用
支持楼主 学习了，谢谢