批量相同组合图元关联修改

【KAIXIN】

本人对此真是一点办法也没有了！！！

我有试过用块，也有试过用组，却总是不行！

请大家帮忙看看，谢谢！

下面是录制的动画（要实现的），试试用LISP或者.....是否可以?



说明：忘记发悬赏了，要是有哪位朋友弄好了，奖励：500明经币！



该贴已经同步到 【KAIXIN】的微博

lpx530115

大佬，你好，这个（批量相同组合图元关联修改）http://bbs.mjtd.com/forum.php?mod=viewthread&tid=100248的帖子里的完整程序，想用在冲压模具设计上试用一下，可以提供一下相关完整程序吗？谢谢。

lpx530115

2014CAD可以使用了，非常感谢大佬的程序。

qianzj

建矩形块 获得基点 框选范围 根据矩形块基点 先删除后复制

阿然

这个如何？
先上个fas，可以了就放源码～
定义图源:def 更新引用upd

ScmTools

这个思路还有点意思,只是快放假了现在没有心思写了,等年后有空试试

【KAIXIN】

阿然 发表于 2013-1-26 20:07
这个如何？
先上个fas，可以了就放源码～
定义图源:def 更新引用upd

基本上可以了，

上图中的是矩形和多边形，然兄的只弄了多边形，需要改进！

阿然

好吧，不纠结外框形状了


请重新下载fas测试

hhhlike

然兄高手，这个功能不错

阿然

说好了的代码，请大家指导，感觉写的还不完善

1. (vl-load-com)
   
2. (setvar "cmdecho" 0)
   
3. (setq *AcadDoc* (vla-get-ActiveDocument (vlax-get-Acad-Object)))
   
4. (setq *MoSpace* (vla-get-ModelSpace *AcadDoc*))
   
5. 
   
6. (defun c:def (/ ss obj)
   
7.   (if (and (setq obj
   
8.       (vlax-ename->vla-object (car (entsel "\n选择一个闭合线:")))
   
9.      )
   
10.      (vlax-curve-isclosed obj)
    
11.      (setq sourname (getstring "\n输入图源名:"))
    
12.       )
    
13.     (progn
    
14.       (xr:setxdata obj (list "Test_app" sourname))
    
15.       (princ)
    
16.     )
    
17.     (progn
    
18.       (princ "\n用户取消或者图元不闭合:")
    
19.       (princ)
    
20.     )
    
21.   )
    
22. )
    
23. 
    
24. (defun c:upd (/  FACTOR MAXPT MAXPT1 MINPT MINPT1 OBJ PTS PTS1 SS SS1 TEMPSS TEMPVLALST VLALST VLALST1 XDATA)
    
25.   (if (and (setq obj (vlax-ename->vla-object (car (entsel "\n选择图源:"))))
    
26.      (setq xdata (xr:getxdata obj))
    
27.       )
    
28.     (progn
    
29.       (vla-getboundingbox obj 'minpt 'maxpt)
    
30.       (setq minpt (vlax-safearray->list minpt)
    
31.       maxpt (vlax-safearray->list maxpt)
    
32.       )
    
33.       (setq pts (xr:makepts obj))
    
34.       (setq ss (ssget "WP" pts))
    
35.       (setq vlalst (lm:ss->vla ss)
    
36.       ss     nil
    
37.       )
    
38.       (princ "\n选择需要修改的引用:")
    
39.       (setq ss1 (ssget '((-3 ("Test_app")))))
    
40.       (setq vlalst1 (lm:ss->vla ss1)
    
41.       ss1      nil
    
42.       )
    
43.       (foreach vla vlalst1
    
44.   (if (= (cadr (xr:getxdata vla)) (cadr xdata))
    
45.     (progn
    
46.       (vla-getboundingbox vla 'minpt1 'maxpt1)
    
47.       (setq minpt1 (vlax-safearray->list minpt1)
    
48.       maxpt1 (vlax-safearray->list maxpt1)
    
49.       )
    
50.       (setq pts1 (xr:makepts vla))
    
51.       (setq tempss (ssget "WP" pts1))
    
52.       (setq tempvlalst
    
53.        (lm:ss->vla tempss)
    
54.       tempss nil
    
55.       )
    
56.       (xr:delete tempvlalst)
    
57.       (setq factor
    
58.        (/ (distance minpt1 maxpt1) (distance minpt maxpt))
    
59.       )
    
60.       (xr:scale (xr:copyandmove vlalst minpt minpt1)
    
61.           minpt1
    
62.           factor
    
63.       )
    
64.     )
    
65.   )
    
66.       )
    
67.       (princ)
    
68.     )
    
69.     (progn
    
70.       (princ "\n选择的物体非已定义图源或者用户取消!")
    
71.       (princ)
    
72.     )
    
73.   )
    
74. )
    
75. 
    
76. (defun xr:makepts (obj / pts i objlength len precision)
    
77. ;;; (setq objname (vla-get-objectname obj))
    
78.   (setq  objlength (vlax-curve-getdistatparam
    
79.         obj
    
80.         (vlax-curve-getendparam obj)
    
81.       )
    
82.   )
    
83.   (setq
    
84.     i        -1
    
85.     precision 20
    
86.     len        (/ objlength precision)
    
87.   )
    
88.   (repeat precision ;_精度要高就设置多点
    
89.     (setq pt (vlax-curve-getpointatdist obj (* (setq i (1+ i)) len)))
    
90.     (setq pts (append pts (list pt)))
    
91.   )
    
92. )
    
93. 
    
94. 
    
95. 
    
96. 
    
97. (defun xr:copyandmove (vlalst basept distpt / result)
    
98.   (if vlalst
    
99.     (mapcar '(lambda (x)
    
100.          (vlax-invoke-method
     
101.      x
     
102.      'Move
     
103.      (vlax-3d-point basept)
     
104.      (vlax-3d-point distpt)
     
105.          )
     
106.        )
     
107.       (setq result (mapcar '(lambda (x)
     
108.             (vlax-invoke-method x 'Copy)
     
109.           )
     
110.          vlalst
     
111.        )
     
112.       )
     
113.     )
     
114.   )
     
115.   result
     
116. )
     
117. 
     
118. (defun xr:scale  (vlalst basept factor)
     
119.   (if vlalst
     
120.     (mapcar '(lambda (x)
     
121.          (vlax-invoke-method
     
122.      x
     
123.      'ScaleEntity
     
124.      (vlax-3d-point basept)
     
125.      factor
     
126.          )
     
127.        )
     
128.       vlalst
     
129.     )
     
130.   )
     
131. )
     
132. 
     
133. 
     
134. (defun Xr:getxdata (obj / xdatatype xdata)
     
135.   (vla-getxdata obj "" ''xdatatype 'xdata)
     
136.   (mapcar 'vlax-variant-value (vlax-safearray->list xdata))
     
137. )
     
138. 
     
139. (defun Xr:delete (objlist / obj)
     
140.   (foreach obj objlist
     
141.     (if  (not (vlax-erased-p obj))
     
142.       (vla-erase obj)
     
143.     )
     
144.   )
     
145. )
     
146. 
     
147. (defun Xr:setXdata
     
148.        (obj datalst / datatype datatypelst data xdatatype xdata)
     
149.   (foreach data  datalst
     
150.     (cond
     
151.       ((= data (car datalst))
     
152.        (setq datatype 1001)
     
153.       )
     
154.       ((= (type data) 'INT)
     
155.        (setq datatype 1070)
     
156.       )
     
157.       ((= (type data) 'REAL)
     
158.        (setq datatype 1040)
     
159.       )
     
160.       ((= (type data) 'STR)
     
161.        (setq datatype 1000)
     
162.       )
     
163.     )
     
164.     (setq datatypelst (cons datatype datatypelst))
     
165.   )
     
166.   (setq datatypelst (reverse datatypelst))
     
167.   (setq xdatatype (xr:list->int-array datatypelst))
     
168.   (setq xdata (xr:list->var-array datalst))
     
169.   (vla-setxdata obj xdatatype xdata)
     
170. )
     
171. 
     
172. 
     
173. (defun Xr:list->int-Array (intList / arraySpace sArray)
     
174.   (setq  arraySpace
     
175.    (vlax-make-safearray
     
176.      vlax-vbInteger    ; 元素类型
     
177.      (cons 0
     
178.      (1- (length intList))
     
179.      )        ; 数组维数
     
180.    )
     
181.   )
     
182.   (setq sArray (vlax-safearray-fill arraySpace intList))
     
183. )
     
184. (defun Xr:list->Obj-Array (objList / arraySpace sArray)
     
185.   (setq  arraySpace
     
186.    (vlax-make-safearray
     
187.      vlax-vbObject    ; 元素类型
     
188.      (cons 0
     
189.      (1- (length objList))
     
190.      )        ; 数组维数
     
191.    )
     
192.   )
     
193.   (setq sArray (vlax-safearray-fill arraySpace objList))
     
194. )
     
195. 
     
196. 
     
197. (defun Xr:list->var-Array (varList / arraySpace sArray)
     
198.   (setq  arraySpace
     
199.    (vlax-make-safearray
     
200.      vlax-vbvariant    ; 元素类型
     
201.      (cons 0
     
202.      (1- (length varList))
     
203.      )        ; 数组维数
     
204.    )
     
205.   )
     
206.   (setq sArray (vlax-safearray-fill arraySpace varList))
     
207. )
     
208. 
     
209. (defun LM:ss->vla (ss / i l)
     
210.   ;; ?Lee Mac 2010
     
211.   (if ss
     
212.     (repeat (setq i (sslength ss))
     
213.       (setq
     
214.   l (cons  (vlax-ename->vla-object (ssname ss (setq i (1- i))))
     
215.     l
     
216.     )
     
217.       )
     
218.     )
     
219.   )
     
220. )
     
221. 
     
222. (defun lastent (/ a b)
     
223.   (if (setq a (entlast)) ;_可获取最后一个主图元
     
224.     (while (setq b (entnext a)) ;_检查其后是否有子图元   
     
225.       (setq a b) ;_设定循环直到无子图元为止
     
226.     )
     
227.   )
     
228.   a
     
229. )
     

(vl-load-com)<br /> (setvar "cmdecho" 0)<br /> (setq *AcadDoc* (vla-get-ActiveDocument (vlax-get-Acad-Object)))<br /> (setq *MoSpace* (vla-get-ModelSpace *AcadDoc*))<br /> <br /> (defun c:def (/ ss obj)<br />   (if (and (setq obj<br />       (vlax-ename->vla-object (car (entsel "\n选择一个闭合线:")))<br />      )<br />      (vlax-curve-isclosed obj)<br />      (setq sourname (getstring "\n输入图源名:"))<br />       )<br />     (progn<br />       (xr:setxdata obj (list "Test_app" sourname))<br />       (princ)<br />     )<br />     (progn<br />       (princ "\n用户取消或者图元不闭合:")<br />       (princ)<br />     )<br />   )<br /> )<br /> <br /> (defun c:upd (/  FACTOR MAXPT MAXPT1 MINPT MINPT1 OBJ PTS PTS1 SS SS1 TEMPSS TEMPVLALST VLALST VLALST1 XDATA)<br />   (if (and (setq obj (vlax-ename->vla-object (car (entsel "\n选择图源:"))))<br />      (setq xdata (xr:getxdata obj))<br />       )<br />     (progn<br />       (vla-getboundingbox obj 'minpt 'maxpt)<br />       (setq minpt (vlax-safearray->list minpt)<br />       maxpt (vlax-safearray->list maxpt)<br />       )<br />       (setq pts (xr:makepts obj))<br />       (setq ss (ssget "WP" pts))<br />       (setq vlalst (lm:ss->vla ss)<br />       ss     nil<br />       )<br />       (princ "\n选择需要修改的引用:")<br />       (setq ss1 (ssget '((-3 ("Test_app")))))<br />       (setq vlalst1 (lm:ss->vla ss1)<br />       ss1      nil<br />       )<br />       (foreach vla vlalst1<br />   (if (= (cadr (xr:getxdata vla)) (cadr xdata))<br />     (progn<br />       (vla-getboundingbox vla 'minpt1 'maxpt1)<br />       (setq minpt1 (vlax-safearray->list minpt1)<br />       maxpt1 (vlax-safearray->list maxpt1)<br />       )<br />       (setq pts1 (xr:makepts vla))<br />       (setq tempss (ssget "WP" pts1))<br />       (setq tempvlalst<br />        (lm:ss->vla tempss)<br />       tempss nil<br />       )<br />       (xr:delete tempvlalst)<br />       (setq factor<br />        (/ (distance minpt1 maxpt1) (distance minpt maxpt))<br />       )<br />       (xr:scale (xr:copyandmove vlalst minpt minpt1)<br />           minpt1<br />           factor<br />       )<br />     )<br />   )<br />       )<br />       (princ)<br />     )<br />     (progn<br />       (princ "\n选择的物体非已定义图源或者用户取消!")<br />       (princ)<br />     )<br />   )<br /> )<br /> <br /> (defun xr:makepts (obj / pts i objlength len precision)<br /> ;;; (setq objname (vla-get-objectname obj))<br />   (setq  objlength (vlax-curve-getdistatparam<br />         obj<br />         (vlax-curve-getendparam obj)<br />       )<br />   )<br />   (setq<br />     i        -1<br />     precision 20<br />     len        (/ objlength precision)<br />   )<br />   (repeat precision ;_精度要高就设置多点<br />     (setq pt (vlax-curve-getpointatdist obj (* (setq i (1+ i)) len)))<br />     (setq pts (append pts (list pt)))<br />   )<br /> )<br /> <br /> <br /> <br /> <br /> (defun xr:copyandmove (vlalst basept distpt / result)<br />   (if vlalst<br />     (mapcar '(lambda (x)<br />          (vlax-invoke-method<br />      x<br />      'Move<br />      (vlax-3d-point basept)<br />      (vlax-3d-point distpt)<br />          )<br />        )<br />       (setq result (mapcar '(lambda (x)<br />             (vlax-invoke-method x 'Copy)<br />           )<br />          vlalst<br />        )<br />       )<br />     )<br />   )<br />   result<br /> )<br /> <br /> (defun xr:scale  (vlalst basept factor)<br />   (if vlalst<br />     (mapcar '(lambda (x)<br />          (vlax-invoke-method<br />      x<br />      'ScaleEntity<br />      (vlax-3d-point basept)<br />      factor<br />          )<br />        )<br />       vlalst<br />     )<br />   )<br /> )<br /> <br /> <br /> (defun Xr:getxdata (obj / xdatatype xdata)<br />   (vla-getxdata obj "" ''xdatatype 'xdata)<br />   (mapcar 'vlax-variant-value (vlax-safearray->list xdata))<br /> )<br /> <br /> (defun Xr:delete (objlist / obj)<br />   (foreach obj objlist<br />     (if  (not (vlax-erased-p obj))<br />       (vla-erase obj)<br />     )<br />   )<br /> )<br /> <br /> (defun Xr:setXdata<br />        (obj datalst / datatype datatypelst data xdatatype xdata)<br />   (foreach data  datalst<br />     (cond<br />       ((= data (car datalst))<br />        (setq datatype 1001)<br />       )<br />       ((= (type data) 'INT)<br />        (setq datatype 1070)<br />       )<br />       ((= (type data) 'REAL)<br />        (setq datatype 1040)<br />       )<br />       ((= (type data) 'STR)<br />        (setq datatype 1000)<br />       )<br />     )<br />     (setq datatypelst (cons datatype datatypelst))<br />   )<br />   (setq datatypelst (reverse datatypelst))<br />   (setq xdatatype (xr:list->int-array datatypelst))<br />   (setq xdata (xr:list->var-array datalst))<br />   (vla-setxdata obj xdatatype xdata)<br /> )<br /> <br /> <br /> (defun Xr:list->int-Array (intList / arraySpace sArray)<br />   (setq  arraySpace<br />    (vlax-make-safearray<br />      vlax-vbInteger    ; 元素类型<br />      (cons 0<br />      (1- (length intList))<br />      )        ; 数组维数<br />    )<br />   )<br />   (setq sArray (vlax-safearray-fill arraySpace intList))<br /> )<br /> (defun Xr:list->Obj-Array (objList / arraySpace sArray)<br />   (setq  arraySpace<br />    (vlax-make-safearray<br />      vlax-vbObject    ; 元素类型<br />      (cons 0<br />      (1- (length objList))<br />      )        ; 数组维数<br />    )<br />   )<br />   (setq sArray (vlax-safearray-fill arraySpace objList))<br /> )<br /> <br /> <br /> (defun Xr:list->var-Array (varList / arraySpace sArray)<br />   (setq  arraySpace<br />    (vlax-make-safearray<br />      vlax-vbvariant    ; 元素类型<br />      (cons 0<br />      (1- (length varList))<br />      )        ; 数组维数<br />    )<br />   )<br />   (setq sArray (vlax-safearray-fill arraySpace varList))<br /> )<br /> <br /> (defun LM:ss->vla (ss / i l)<br />   ;; ?Lee Mac 2010<br />   (if ss<br />     (repeat (setq i (sslength ss))<br />       (setq<br />   l (cons  (vlax-ename->vla-object (ssname ss (setq i (1- i))))<br />     l<br />     )<br />       )<br />     )<br />   )<br /> )<br /> <br /> (defun lastent (/ a b)<br />   (if (setq a (entlast)) ;_可获取最后一个主图元<br />     (while (setq b (entnext a)) ;_检查其后是否有子图元    <br />       (setq a b) ;_设定循环直到无子图元为止<br />     )<br />   )<br />   a<br /> )<br />

---

qianzj

阿然 发表于 2013-1-28 10:01
说好了的代码，请大家指导，感觉写的还不完善

---

很厉害  下来学习!

asd19400

传说中的APS