[求助]：替换图块并保持插入尺寸（原大小）之LISP程序

武陵山人

求可批量替换图块并保持被替换图块原大小的LISP程序

武陵山人

最初由 fsxm 发布
[B]用vla-GetBoundingBox可以:
类似的看有用不:http://www.xdcad.net/forum/showthread.php?s=&threadid=597610
改动一下就成了:看看是不是你要求的了?
[code]
(vl-load-com)
(defun substblk        (newblkn... [/B]

谢谢，程序可以达到我的要求了，不过每次替换都要输入块名，比较麻烦，可不可以改成直接选取样块呀？

liuyj

最初由 武陵山人 发布
[B]求可批量替换图块并保持被替换图块原大小的LISP程序 [/B]

2. 
   
3.   [FONT=courier new]
   
4. (defun c:bth (/ cn oldb newb len se1 e0 e1 bn b0)
   
5.   (command "color" "")
   
6.   (setvar "unitmode" 0)
   
7.   (princ "\n选择块实体:")
   
8.   (setq        se1  (ssget '((0 . "INSERT")))
   
9.         oldb nil
   
10.         newb nil
    
11.   )
    
12.   (if se1
    
13.     (progn
    
14.       (setq bn (getstring "\n批量替换*/<新块名>(回车选取样块):"))
    
15.       (cond
    
16.         ((= bn "*")
    
17.          (setq oldb (strcase (getstring "\n旧块名:"))
    
18.                newb (strcase (getstring "\n新块名:"))
    
19.          )
    
20.         )
    
21.         ((= bn "")
    
22.          (setq b0 nil)
    
23.          (while        (not b0)
    
24.            (initget " ")
    
25.            (setq b0 (entsel "\n选取样块："))
    
26.            (cond
    
27.              ((= (type b0) 'STR) (setq b0 t))
    
28.              ((and
    
29.                 (= (type b0) 'LIST)
    
30.                 (/= (cdr (assoc 0 (setq b0 (entget (car b0))))) "INSERT")
    
31.               )
    
32.               (setq b0 nil)
    
33.              )
    
34.              (t (setq bn (cdr (assoc 2 b0))))
    
35.            )
    
36.          )
    
37.         )
    
38.         (t nil)
    
39.       )
    
40.       (setq len (sslength se1))
    
41.       (while (> len 0)
    
42.         (setq e0 (ssname se1 0)
    
43.               e1 (entget e0)
    
44.         )
    
45.         (if (and oldb newb)
    
46.           (if (= (strcase (cdr (assoc 2 e1))) oldb)
    
47.             (setq e1 (subst (cons 2 newb) (assoc 2 e1) e1))
    
48.           )
    
49.           (setq e1 (subst (cons 2 bn) (assoc 2 e1) e1))
    
50.         )
    
51.         (entmod e1)
    
52.         (entupd e0)
    
53.         (ssdel e0 se1)
    
54.         (if se1
    
55.           (setq len (sslength se1))
    
56.         )
    
57.       )
    
58.     )
    
59.   )
    
60.   (princ)
    
61. )
    
62.   [/FONT]
    

<br />   [FONT=courier new]<br /> (defun c:bth (/ cn oldb newb len se1 e0 e1 bn b0)<br />   (command "color" "")<br />   (setvar "unitmode" 0)<br />   (princ "\n选择块实体:")<br />   (setq        se1  (ssget '((0 . "INSERT")))<br />         oldb nil<br />         newb nil<br />   )<br />   (if se1<br />     (progn<br />       (setq bn (getstring "\n批量替换*/<新块名>(回车选取样块):"))<br />       (cond<br />         ((= bn "*")<br />          (setq oldb (strcase (getstring "\n旧块名:"))<br />                newb (strcase (getstring "\n新块名:"))<br />          )<br />         )<br />         ((= bn "")<br />          (setq b0 nil)<br />          (while        (not b0)<br />            (initget " ")<br />            (setq b0 (entsel "\n选取样块："))<br />            (cond<br />              ((= (type b0) 'STR) (setq b0 t))<br />              ((and<br />                 (= (type b0) 'LIST)<br />                 (/= (cdr (assoc 0 (setq b0 (entget (car b0))))) "INSERT")<br />               )<br />               (setq b0 nil)<br />              )<br />              (t (setq bn (cdr (assoc 2 b0))))<br />            )<br />          )<br />         )<br />         (t nil)<br />       )<br />       (setq len (sslength se1))<br />       (while (> len 0)<br />         (setq e0 (ssname se1 0)<br />               e1 (entget e0)<br />         )<br />         (if (and oldb newb)<br />           (if (= (strcase (cdr (assoc 2 e1))) oldb)<br />             (setq e1 (subst (cons 2 newb) (assoc 2 e1) e1))<br />           )<br />           (setq e1 (subst (cons 2 bn) (assoc 2 e1) e1))<br />         )<br />         (entmod e1)<br />         (entupd e0)<br />         (ssdel e0 se1)<br />         (if se1<br />           (setq len (sslength se1))<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />   [/FONT]<br />

雨箭风刀

楼上的程序块定义尺寸大小必须一样
如果不一样，可以插入后调整x，y比例即可

武陵山人

liuyj 兄提供的程序不能达到我的目的，替换后还要重新调整图块的比例才能使图块的大小一致。谁能帮忙写一个可以一步搞定的程序呀？

xyp1964

“图块原大小”的含义不明确，比如一个圆的和一个方的块，如何保证图块原大小？

武陵山人

最初由 xyp1964 发布
[B]“图块原大小”的含义不明确，比如一个圆的和一个方的块，如何保证图块原大小？ [/B]

我主要是用于树木图块的替换，都是圆形的。

fsxm

用vla-GetBoundingBox可以:
类似的看有用不:http://www.xdcad.net/forum/showthread.php?s=&threadid=597610
改动一下就成了:看看是不是你要求的了?

2. 
   
3. (vl-load-com)
   
4. (defun substblk        (newblkname             oldblk    /         box
   
5.                  boxmax           boxmin    insp      newblk         newblkname
   
6.                  newbox           newmax    newmin    oldblk         scx
   
7.                  scy
   
8.                 )
   
9.   (vla-GetBoundingBox
   
10.     (vlax-ename->vla-object oldblk)
    
11.     'boxmin
    
12.     'boxmax
    
13.   )
    
14.   (setq        boxmin (vlax-safearray->list boxmin)
    
15.         boxmax (vlax-safearray->list boxmax)
    
16.         box    (mapcar '- boxmax boxmin)
    
17.   )
    
18.   (entmake
    
19.     (list
    
20.       '(0 . "INSERT")
    
21.       '(100 . "AcDbEntity")
    
22.       '(100 . "AcDbBlockReference")
    
23.       (cons 2 newblkname)
    
24.       '(10 0.0 0.0 0.0)
    
25.       '(41 . 1.0)
    
26.       '(42 . 1.0)
    
27.       '(43 . 1.0)
    
28.     )
    
29.   )
    
30.   (setq newblk (entlast))
    
31.   (vla-GetBoundingBox
    
32.     (vlax-ename->vla-object newblk)
    
33.     'newmin
    
34.     'newmax
    
35.   )
    
36.   (setq        newmin (vlax-safearray->list newmin)
    
37.         newmax (vlax-safearray->list newmax)
    
38.         newbox (mapcar '- newmax newmin)
    
39.   )
    
40.   (setq        scx  (/ (car box) (car newbox))
    
41.         scy  (/ (cadr box) (cadr newbox))
    
42.         insp (mapcar '- boxmin (mapcar '* newmin (list scx scy 0)))
    
43.   )
    
44.   (entmod (list        (cons -1 newblk)
    
45.                 (cons 10 insp)
    
46.                 (cons 41 scx)
    
47.                 (cons 42 scy)
    
48.           )
    
49.   )
    
50.   (entdel oldblk)
    
51. )
    
52. (defun c:test ()
    
53.   (cond        ((and
    
54.            (setq newblkname (getstring "\n新块名:"))
    
55.            (if (tblsearch "block" newblkname)
    
56.              t
    
57.              (alert "查无此块!")
    
58.            )
    
59.            (setq ss (ssget '((0 . "insert")))) ;请加入自定过滤
    
60.          )
    
61.          (setq i -1)
    
62.          (repeat
    
63.            (sslength ss)
    
64.             (setq oldblk (ssname ss (setq i (1+ i))))
    
65.             (substblk newblkname oldblk)
    
66.          )
    
67.         )
    
68.   )
    
69.   (princ)
    
70. )
    
71. 
    

<br /> (vl-load-com)<br /> (defun substblk        (newblkname             oldblk    /         box<br />                  boxmax           boxmin    insp      newblk         newblkname<br />                  newbox           newmax    newmin    oldblk         scx<br />                  scy<br />                 )<br />   (vla-GetBoundingBox<br />     (vlax-ename->vla-object oldblk)<br />     'boxmin<br />     'boxmax<br />   )<br />   (setq        boxmin (vlax-safearray->list boxmin)<br />         boxmax (vlax-safearray->list boxmax)<br />         box    (mapcar '- boxmax boxmin)<br />   )<br />   (entmake<br />     (list<br />       '(0 . "INSERT")<br />       '(100 . "AcDbEntity")<br />       '(100 . "AcDbBlockReference")<br />       (cons 2 newblkname)<br />       '(10 0.0 0.0 0.0)<br />       '(41 . 1.0)<br />       '(42 . 1.0)<br />       '(43 . 1.0)<br />     )<br />   )<br />   (setq newblk (entlast))<br />   (vla-GetBoundingBox<br />     (vlax-ename->vla-object newblk)<br />     'newmin<br />     'newmax<br />   )<br />   (setq        newmin (vlax-safearray->list newmin)<br />         newmax (vlax-safearray->list newmax)<br />         newbox (mapcar '- newmax newmin)<br />   )<br />   (setq        scx  (/ (car box) (car newbox))<br />         scy  (/ (cadr box) (cadr newbox))<br />         insp (mapcar '- boxmin (mapcar '* newmin (list scx scy 0)))<br />   )<br />   (entmod (list        (cons -1 newblk)<br />                 (cons 10 insp)<br />                 (cons 41 scx)<br />                 (cons 42 scy)<br />           )<br />   )<br />   (entdel oldblk)<br /> )<br /> (defun c:test ()<br />   (cond        ((and<br />            (setq newblkname (getstring "\n新块名:"))<br />            (if (tblsearch "block" newblkname)<br />              t<br />              (alert "查无此块!")<br />            )<br />            (setq ss (ssget '((0 . "insert")))) ;请加入自定过滤<br />          )<br />          (setq i -1)<br />          (repeat<br />            (sslength ss)<br />             (setq oldblk (ssname ss (setq i (1+ i))))<br />             (substblk newblkname oldblk)<br />          )<br />         )<br />   )<br />   (princ)<br /> )<br /> <br />

fsxm

(setq newblkname (getstring "\n新块名:"))
换为:
(setq newblkname (cdr (assoc 2 (entget (car (entsel))))))

武陵山人

谢谢 fsxm  兄！很好用，解决了一直以来困扰我的一个问题。

dwg001

不错的东东。
如果新块带属性，用新块替换旧块时新块的属性好像不见了。

武陵山人

还有一个问题要麻烦 fsxm 兄：
对象块被替换后会将生成的对象改变到当前图层，能不能让生成的对象保留在被替换块原来的图层上？

fsxm

谢谢eachy老大又送我一分啦
武陵山人斑竹:

1. 
   
2. (entmod        (list (cons -1 newblk)
   
3.               (cons 10 insp)
   
4.               (cons 41 scx)
   
5.               (cons 42 scy)
   
6.         )
   
7. )
   
8. 改成：
   
9. (entmod        (list (cons -1 newblk)
   
10.               (assoc 8 (entget oldblk))        ;图层
    
11.               (cons 10 insp)
    
12.               (cons 41 scx)
    
13.               (cons 42 scy)
    
14.         )
    
15. )
    

复制代码

dwg001老兄的意见提的好啊~新块带属性的确要烦一点~
我想这样解决吧：
前面的entmake改用command~这样可以在不增加代码基础上加上属性
后面entmod时也不便处理属性
不妨在entmod前在新块基础上再entmake一个无名块
以后就entmod这个无名块好了后再炸开还原为带属性块~
理论上可行性能通过了~现在没时间来写可能要到下星期日