[原创]一个块替换程序

树櫴希德

1. ;; =================================================================
   
2. ;;; 块替换；选择源块A，然后选择需要替换成块A的块B，再选择一个区域，然后把这个区域里的块B换成块A
   
3. ;;; 作者：langjs   　　　　命令：KTH 　　　　　  日期2011年3月22日
   
4. ;;; =================================================================
   
5. (defun C:KTH (/ ent ent1 ent2 i kming1 kming2 lst name1 name2 pt ss t1)
   
6.   (setvar "cmdecho" 0)         ; 关闭命令响应
   
7.   (setq $orr *error*)
   
8.   (setq *error* #err2)         ; 当程序出错时就会执行#err函数
   
9.   (command ".UNDO" "BE")        ; 设置UNDO起点
   
10.   (setq t1 1)
    
11.   (while (= t1 1)
    
12.     (setq name1 (car (entsel "\n选择源块A：")))
    
13.     (setq ent1 (entget name1))
    
14.     (if (= (cdr (assoc 0 ent1)) "INSERT")
    
15.       (progn
    
16. (setq kming1 (cdr (assoc 2 ent1)))
    
17. (redraw name1 3)
    
18. (setq t1 2)
    
19.       )
    
20.       (princ "\n选择源块A：")
    
21.     )
    
22.   )
    
23.   (while (= t1 2)
    
24.     (setq name2 (car (entsel "\n选择替换块B：")))
    
25.     (setq ent2 (entget name2))
    
26.     (if (= (cdr (assoc 0 ent2)) "INSERT")
    
27.       (progn
    
28. (setq kming2 (cdr (assoc 2 ent2)))
    
29. (redraw name2 3)
    
30. (setq t1 3)
    
31.       )
    
32.       (princ "\n选择替换块B：")
    
33.     )
    
34.   )
    
35.   (while (= t1 3)
    
36.     (prompt "\n选择替换区域:")
    
37.     (setvar "nomutt" 1)
    
38.     (setq ss (ssget (list (cons 2 kming2))))
    
39.     (setvar "nomutt" 0)
    
40.     (if ss
    
41.       (setq t1 4)
    
42.     )
    
43.   )
    
44.   (redraw name1 4)
    
45.   (redraw name2 4)
    
46.   (setq lst '())
    
47.   (repeat (setq i (sslength ss))
    
48.     (setq ent (ssname ss (setq i (1- i))))
    
49.     (setq ent (entget ent))
    
50.     (setq lst (cons (cdr (assoc 10 ent)) lst))
    
51.   )
    
52.   (command "erase" ss "")        ; 删除块
    
53.   (setq i 0)
    
54.   (while (< i (length lst))
    
55.     (setq PT (nth i lst))
    
56.     (command "INSERT" kming1 PT 1 1 0) ; 插入块，
    
57.     (nth i lst)
    
58.     (setq i (+ i 1))
    
59.   )
    
60.   (command ".UNDO" "E")         ; 设置UNDO终点
    
61.   (setq *error* $orr)
    
62.   (princ)
    
63. )
    
64. ;;; 出错处理函数
    
65. (defun #err2 (s)
    
66.   (command ".UNDO" "E")         ; 设置UNDO终点
    
67.   (redraw name1 4)
    
68.   (redraw name2 4)
    
69.   (princ)
    
70.   (setq *error* $orr)
    
71. )

;; =================================================================<br /> ;;; 块替换；选择源块A，然后选择需要替换成块A的块B，再选择一个区域，然后把这个区域里的块B换成块A<br /> ;;; 作者：langjs   　　　　命令：KTH 　　　　　  日期2011年3月22日<br /> ;;; =================================================================<br /> (defun C:KTH (/ ent ent1 ent2 i kming1 kming2 lst name1 name2 pt ss t1)<br />   (setvar "cmdecho" 0)         ; 关闭命令响应<br />   (setq $orr *error*)<br />   (setq *error* #err2)         ; 当程序出错时就会执行#err函数<br />   (command ".UNDO" "BE")        ; 设置UNDO起点<br />   (setq t1 1)<br />   (while (= t1 1)<br />     (setq name1 (car (entsel "\n选择源块A：")))<br />     (setq ent1 (entget name1))<br />     (if (= (cdr (assoc 0 ent1)) "INSERT")<br />       (progn<br /> (setq kming1 (cdr (assoc 2 ent1)))<br /> (redraw name1 3)<br /> (setq t1 2)<br />       )<br />       (princ "\n选择源块A：")<br />     )<br />   )<br />   (while (= t1 2)<br />     (setq name2 (car (entsel "\n选择替换块B：")))<br />     (setq ent2 (entget name2))<br />     (if (= (cdr (assoc 0 ent2)) "INSERT")<br />       (progn<br /> (setq kming2 (cdr (assoc 2 ent2)))<br /> (redraw name2 3)<br /> (setq t1 3)<br />       )<br />       (princ "\n选择替换块B：")<br />     )<br />   )<br />   (while (= t1 3)<br />     (prompt "\n选择替换区域:")<br />     (setvar "nomutt" 1)<br />     (setq ss (ssget (list (cons 2 kming2))))<br />     (setvar "nomutt" 0)<br />     (if ss<br />       (setq t1 4)<br />     )<br />   )<br />   (redraw name1 4)<br />   (redraw name2 4)<br />   (setq lst '())<br />   (repeat (setq i (sslength ss))<br />     (setq ent (ssname ss (setq i (1- i))))<br />     (setq ent (entget ent))<br />     (setq lst (cons (cdr (assoc 10 ent)) lst))<br />   )<br />   (command "erase" ss "")        ; 删除块<br />   (setq i 0)<br />   (while (< i (length lst))<br />     (setq PT (nth i lst))<br />     (command "INSERT" kming1 PT 1 1 0) ; 插入块，<br />     (nth i lst)<br />     (setq i (+ i 1))<br />   )<br />   (command ".UNDO" "E")         ; 设置UNDO终点<br />   (setq *error* $orr)<br />   (princ)<br /> )<br /> ;;; 出错处理函数<br /> (defun #err2 (s)<br />   (command ".UNDO" "E")         ; 设置UNDO终点<br />   (redraw name1 4)<br />   (redraw name2 4)<br />   (princ)<br />   (setq *error* $orr)<br /> )

T  改T1 行吗 大神

tianbeiyuan

先收藏了，好东西啊

wzxcad

正在学习相关块的知识

78946299

块可以直接替换块，就像格式刷一样，万物皆可刷。

ZJKUSO

贱人工具箱应该就是加入了这个功能，替换后块比例变小了

meja

78946299 发表于 2022-4-15 18:41
块可以直接替换块，就像格式刷一样，万物皆可刷。

这是一个很牛的插件啊！

ferious

狼大哥    6666666666666666666666666666666666666666666666666666666666666666666666666

ferious

加载错误？帮忙看下