批量相同组合图元关联修改
本帖最后由 【KAIXIN】 于 2013-1-26 15:31 编辑本人对此真是一点办法也没有了！！！
我有试过用块，也有试过用组，却总是不行！
请大家帮忙看看，谢谢！
下面是录制的动画（要实现的），试试用LISP或者.....是否可以?
说明：忘记发悬赏了，要是有哪位朋友弄好了，奖励：500明经币！
http://bbs.mjtd.com/xwb/images/bgimg/icon_logo.png 该贴已经同步到 【KAIXIN】的微博
本帖最后由 lpx530115 于 2024-11-14 09:49 编辑
大佬，你好，这个（批量相同组合图元关联修改）http://bbs.mjtd.com/forum.php?mod=viewthread&tid=100248的帖子里的完整程序，想用在冲压模具设计上试用一下，可以提供一下相关完整程序吗？谢谢。 2014CAD可以使用了，非常感谢大佬的程序。:lol 建矩形块 获得基点 框选范围 根据矩形块基点 先删除后复制
这个如何？
先上个fas，可以了就放源码～
定义图源:def 更新引用upd
这个思路还有点意思,只是快放假了现在没有心思写了,等年后有空试试 阿然 发表于 2013-1-26 20:07 static/image/common/back.gif
这个如何？
先上个fas，可以了就放源码～
定义图源:def 更新引用upd
基本上可以了，
上图中的是矩形和多边形，然兄的只弄了多边形，需要改进！
好吧，不纠结外框形状了
请重新下载fas测试
然兄高手，这个功能不错 本帖最后由 阿然 于 2013-1-28 10:06 编辑
说好了的代码，请大家指导，感觉写的还不完善
(vl-load-com)
(setvar "cmdecho" 0)
(setq *AcadDoc* (vla-get-ActiveDocument (vlax-get-Acad-Object)))
(setq *MoSpace* (vla-get-ModelSpace *AcadDoc*))
(defun c:def (/ ss obj)
(if (and (setq obj
(vlax-ename->vla-object (car (entsel "\n选择一个闭合线:")))
)
(vlax-curve-isclosed obj)
(setq sourname (getstring "\n输入图源名:"))
)
(progn
(xr:setxdata obj (list "Test_app" sourname))
(princ)
)
(progn
(princ "\n用户取消或者图元不闭合:")
(princ)
)
)
)
(defun c:upd (/FACTOR MAXPT MAXPT1 MINPT MINPT1 OBJ PTS PTS1 SS SS1 TEMPSS TEMPVLALST VLALST VLALST1 XDATA)
(if (and (setq obj (vlax-ename->vla-object (car (entsel "\n选择图源:"))))
(setq xdata (xr:getxdata obj))
)
(progn
(vla-getboundingbox obj 'minpt 'maxpt)
(setq minpt (vlax-safearray->list minpt)
maxpt (vlax-safearray->list maxpt)
)
(setq pts (xr:makepts obj))
(setq ss (ssget "WP" pts))
(setq vlalst (lm:ss->vla ss)
ss nil
)
(princ "\n选择需要修改的引用:")
(setq ss1 (ssget '((-3 ("Test_app")))))
(setq vlalst1 (lm:ss->vla ss1)
ss1 nil
)
(foreach vla vlalst1
(if (= (cadr (xr:getxdata vla)) (cadr xdata))
(progn
(vla-getboundingbox vla 'minpt1 'maxpt1)
(setq minpt1 (vlax-safearray->list minpt1)
maxpt1 (vlax-safearray->list maxpt1)
)
(setq pts1 (xr:makepts vla))
(setq tempss (ssget "WP" pts1))
(setq tempvlalst
(lm:ss->vla tempss)
tempss nil
)
(xr:delete tempvlalst)
(setq factor
(/ (distance minpt1 maxpt1) (distance minpt maxpt))
)
(xr:scale (xr:copyandmove vlalst minpt minpt1)
minpt1
factor
)
)
)
)
(princ)
)
(progn
(princ "\n选择的物体非已定义图源或者用户取消!")
(princ)
)
)
)
(defun xr:makepts (obj / pts i objlength len precision)
;;; (setq objname (vla-get-objectname obj))
(setqobjlength (vlax-curve-getdistatparam
obj
(vlax-curve-getendparam obj)
)
)
(setq
i -1
precision 20
len (/ objlength precision)
)
(repeat precision ;_精度要高就设置多点
(setq pt (vlax-curve-getpointatdist obj (* (setq i (1+ i)) len)))
(setq pts (append pts (list pt)))
)
)
(defun xr:copyandmove (vlalst basept distpt / result)
(if vlalst
(mapcar '(lambda (x)
(vlax-invoke-method
x
'Move
(vlax-3d-point basept)
(vlax-3d-point distpt)
)
)
(setq result (mapcar '(lambda (x)
(vlax-invoke-method x 'Copy)
)
vlalst
)
)
)
)
result
)
(defun xr:scale(vlalst basept factor)
(if vlalst
(mapcar '(lambda (x)
(vlax-invoke-method
x
'ScaleEntity
(vlax-3d-point basept)
factor
)
)
vlalst
)
)
)
(defun Xr:getxdata (obj / xdatatype xdata)
(vla-getxdata obj "" ''xdatatype 'xdata)
(mapcar 'vlax-variant-value (vlax-safearray->list xdata))
)
(defun Xr:delete (objlist / obj)
(foreach obj objlist
(if(not (vlax-erased-p obj))
(vla-erase obj)
)
)
)
(defun Xr:setXdata
(obj datalst / datatype datatypelst data xdatatype xdata)
(foreach datadatalst
(cond
((= data (car datalst))
(setq datatype 1001)
)
((= (type data) 'INT)
(setq datatype 1070)
)
((= (type data) 'REAL)
(setq datatype 1040)
)
((= (type data) 'STR)
(setq datatype 1000)
)
)
(setq datatypelst (cons datatype datatypelst))
)
(setq datatypelst (reverse datatypelst))
(setq xdatatype (xr:list->int-array datatypelst))
(setq xdata (xr:list->var-array datalst))
(vla-setxdata obj xdatatype xdata)
)
(defun Xr:list->int-Array (intList / arraySpace sArray)
(setqarraySpace
(vlax-make-safearray
vlax-vbInteger ; 元素类型
(cons 0
(1- (length intList))
) ; 数组维数
)
)
(setq sArray (vlax-safearray-fill arraySpace intList))
)
(defun Xr:list->Obj-Array (objList / arraySpace sArray)
(setqarraySpace
(vlax-make-safearray
vlax-vbObject ; 元素类型
(cons 0
(1- (length objList))
) ; 数组维数
)
)
(setq sArray (vlax-safearray-fill arraySpace objList))
)
(defun Xr:list->var-Array (varList / arraySpace sArray)
(setqarraySpace
(vlax-make-safearray
vlax-vbvariant ; 元素类型
(cons 0
(1- (length varList))
) ; 数组维数
)
)
(setq sArray (vlax-safearray-fill arraySpace varList))
)
(defun LM:ss->vla (ss / i l)
;; ?Lee Mac 2010
(if ss
(repeat (setq i (sslength ss))
(setq
l (cons(vlax-ename->vla-object (ssname ss (setq i (1- i))))
l
)
)
)
)
)
(defun lastent (/ a b)
(if (setq a (entlast)) ;_可获取最后一个主图元
(while (setq b (entnext a)) ;_检查其后是否有子图元
(setq a b) ;_设定循环直到无子图元为止
)
)
a
)
阿然 发表于 2013-1-28 10:01 static/image/common/back.gif
说好了的代码，请大家指导，感觉写的还不完善
很厉害下来学习! 传说中的APS
页:
[1]
2