[原创]一个块替换程序

langjs

;;; =================================================================
;;; 块替换；选择源块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

楼主的程序有欠缺，没有计算替换后的块比例

树櫴希德

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 行吗 大神

ferious

狼大哥    6666666666666666666666666666666666666666666666666666666666666666666666666

yxl88168

正要找这个东东，谢谢楼主。

CAD83

能不能加上可能输入块名，这样可以加上不是图中有的块。哪位出下手改一改

yoyoho

感谢楼主分享源码程序 <谢谢!>

raimo

@langjs :测试之后发现块B消失,块A依然还是原样...这是什么原因?

mandala

这类程序编起来难度不大，但非常实用，可以用来替换符号等等。
我觉得选择区域这段可能利用率不高，会影响程序效率。不如直接改成选择整幅图纸。
另外除了替换块，可以考虑把替换形也加进去，反正只要加一句话就可以。很多符号都是形，而不是块。
最后替换的块，最好以输入块名实现。在实际操作中，恐怕图纸上未必会有要替换的块。

但这类程序真要编得完美也很难。比如，有的块已经被打散。

mandala

CAD83 发表于 2011-3-27 19:11
能不能加上可能输入块名，这样可以加上不是图中有的块。哪位出下手改一改

这个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

shalei021647

这个程序好，下下来备着

zqb05

备用
支持楼主

随意1

学习了，谢谢