谁写过块参照重命名成另一个块的程序

imoses

比如块A，在图中已经有两个块参照X、Y，我现在想通过一个命令，新建一个内含图元跟块A一样的新块B，Y变成B的参照。保持图块A和参照X不变。不知道说清楚了没有。
目前我都是变通的方法，把参照Y拷贝到一张新图中，在新图中把图块A重命名为B，再拷贝回原图纸中，这样比较繁琐。

金鹅起飞

Gu_xl大师好！我加载了您的插件后出现：
命令: tt
閫夋嫨鍥惧潡:
鏂板揩鍚嶇О:
文字为乱码，请问是什么原因？谢谢

Gu_xl

1. (defun c:tt()
   
2.   (if (and
   
3.         (setq e (car(entsel "\n选择图块：")))
   
4.         (setq el (entget e))
   
5.         (= "INSERT" (cdr (assoc 0 el)))
   
6.         (setq newname (getstring "\n输入块名："))
   
7.         (/= "" newname)
   
8.         )
   
9.     (progn
   
10.       (setq cp (cdr (assoc 10 el))
    
11.             xscl (cdr (assoc 41 el))
    
12.             yscl (cdr (assoc 42 el))
    
13.             zscl (cdr (assoc 43 el))
    
14.             rot (cdr (assoc 50 el))
    
15.             )
    
16.       (setq el (subst (cons 41 1.0) (assoc 41 el) el)
    
17.             el (subst (cons 42 1.0) (assoc 42 el)el)
    
18.             el (subst (cons 43 1.0) (assoc 43 el)el)
    
19.             el (subst (cons 50 0) (assoc 50 el)el)
    
20.             )
    
21.       (entmod el)
    
22.       
    
23.       (command "explode" e)
    
24.       (setq ss (ssget "p"))
    
25.       (command "block" newname "non"(trans cp 0 1) ss "")
    
26.       (command "insert" newname "non"(trans cp 0 1) xscl yscl (angtos rot))
    
27.       )
    
28.     )
    
29.   (princ)
    
30.   
    
31.   )

(defun c:tt()<br />   (if (and<br />         (setq e (car(entsel "\n选择图块：")))<br />         (setq el (entget e))<br />         (= "INSERT" (cdr (assoc 0 el)))<br />         (setq newname (getstring "\n输入块名："))<br />         (/= "" newname)<br />         )<br />     (progn<br />       (setq cp (cdr (assoc 10 el))<br />             xscl (cdr (assoc 41 el))<br />             yscl (cdr (assoc 42 el))<br />             zscl (cdr (assoc 43 el))<br />             rot (cdr (assoc 50 el))<br />             )<br />       (setq el (subst (cons 41 1.0) (assoc 41 el) el)<br />             el (subst (cons 42 1.0) (assoc 42 el)el)<br />             el (subst (cons 43 1.0) (assoc 43 el)el)<br />             el (subst (cons 50 0) (assoc 50 el)el)<br />             )<br />       (entmod el)<br />       <br />       (command "explode" e)<br />       (setq ss (ssget "p"))<br />       (command "block" newname "non"(trans cp 0 1) ss "")<br />       (command "insert" newname "non"(trans cp 0 1) xscl yscl (angtos rot))<br />       )<br />     )<br />   (princ)<br />   <br />   )

yoyoho

感谢 G版 分享程序,学习了!

Q1241274614

G版有没有不用command的方法！

imoses

谢谢G版，总算解决了

Gu_xl

Q1241274614 发表于 2015-3-8 17:29
G版有没有不用command的方法！

VLA方法:

1. (defun c:tt (/ E EL OBJ NAME BLOCKS DOC BLKDEFSRC OBJS BLKDEF orign)  (if (and (setq e (car (entsel "\n选择图块:")))
   
2.            (setq el (entget e))
   
3.            (= "INSERT" (cdr (assoc 0 el)))
   
4.            (setq obj (vlax-ename->vla-object e))
   
5.            (setq name (getstring "\n新快名称:"))
   
6.            (/= "" name)
   
7.       )
   
8.     (progn (setq blocks           (vla-get-blocks
   
9.                              (setq
   
10.                                doc (vla-get-ActiveDocument (vlax-get-acad-object))
    
11.                              )
    
12.                            )
    
13.                  blkdefSrc (vla-item blocks (cdr (assoc 2 el)))
    
14.                  orign (vla-get-Origin blkdefSrc)
    
15.            )
    
16.            (vlax-for o blkdefSrc (setq objs (cons o objs)))
    
17.            (if (VL-CATCH-ALL-ERROR-P
    
18.                  (setq
    
19.                    blkdef (VL-CATCH-ALL-APPLY 'vla-item (list blocks name))
    
20.                  )
    
21.                )
    
22.              (setq blkdef (vla-add blocks orign name))
    
23.              (vlax-for o blkdef (vla-delete o))
    
24.            )
    
25.            (vla-CopyObjects
    
26.              doc
    
27.              (vlax-safearray-fill
    
28.                (vlax-make-safearray
    
29.                  vlax-vbObject
    
30.                  (cons 0 (1- (length objs)))
    
31.                )
    
32.                objs
    
33.              )
    
34.              blkdef
    
35.            )
    
36.            (vla-InsertBlock
    
37.              (vla-get-ModelSpace doc)
    
38.              (vla-get-InsertionPoint obj)
    
39.              name
    
40.              (vla-get-XScaleFactor obj)
    
41.              (vla-get-YScaleFactor obj)
    
42.              (vla-get-ZScaleFactor obj)
    
43.              (vla-get-Rotation obj)
    
44.            )
    
45.            (vla-delete obj)
    
46.     )
    
47.   )
    
48.   (princ)
    
49. )

(defun c:tt (/ E EL OBJ NAME BLOCKS DOC BLKDEFSRC OBJS BLKDEF orign)  (if (and (setq e (car (entsel "\n选择图块:")))<br />            (setq el (entget e))<br />            (= "INSERT" (cdr (assoc 0 el)))<br />            (setq obj (vlax-ename->vla-object e))<br />            (setq name (getstring "\n新快名称:"))<br />            (/= "" name)<br />       )<br />     (progn (setq blocks           (vla-get-blocks<br />                              (setq<br />                                doc (vla-get-ActiveDocument (vlax-get-acad-object))<br />                              )<br />                            )<br />                  blkdefSrc (vla-item blocks (cdr (assoc 2 el)))<br />                  orign (vla-get-Origin blkdefSrc)<br />            )<br />            (vlax-for o blkdefSrc (setq objs (cons o objs)))<br />            (if (VL-CATCH-ALL-ERROR-P<br />                  (setq<br />                    blkdef (VL-CATCH-ALL-APPLY 'vla-item (list blocks name))<br />                  )<br />                )<br />              (setq blkdef (vla-add blocks orign name))<br />              (vlax-for o blkdef (vla-delete o))<br />            )<br />            (vla-CopyObjects<br />              doc<br />              (vlax-safearray-fill<br />                (vlax-make-safearray<br />                  vlax-vbObject<br />                  (cons 0 (1- (length objs)))<br />                )<br />                objs<br />              )<br />              blkdef<br />            )<br />            (vla-InsertBlock<br />              (vla-get-ModelSpace doc)<br />              (vla-get-InsertionPoint obj)<br />              name<br />              (vla-get-XScaleFactor obj)<br />              (vla-get-YScaleFactor obj)<br />              (vla-get-ZScaleFactor obj)<br />              (vla-get-Rotation obj)<br />            )<br />            (vla-delete obj)<br />     )<br />   )<br />   (princ)<br /> )

clh521

Gu_xl 发表于 2015-3-8 19:53
VLA方法:

谢谢，我也经常需要这样做，现在有这个程序方便多了

菜卷鱼

Gu_xl 发表于 2015-3-8 19:53
VLA方法:

这样做块可能会跑动，能不能先把块A整体做成块S，再炸开块S里面的块A

Gu_xl

菜卷鱼 发表于 2015-3-11 11:26
这样做块可能会跑动，能不能先把块A整体做成块S，再炸开块S里面的块A

你确信块可能会跑？
先把代码研究明白后再来下结论吧！

菜卷鱼

Gu_xl 发表于 2015-3-8 19:53
VLA方法:

见附件，不能直接上传DWG，改后缀