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

【KAIXIN】 · 发表于 2013-1-26 15:26:28

本帖最后由【KAIXIN】于 2013-1-26 15:31 编辑

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

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

请大家帮忙看看，谢谢！

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

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

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

qianzj · 发表于 2013-1-26 16:23:33

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

阿然 · 发表于 2013-1-26 20:07:06

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

ScmTools · 发表于 2013-1-26 20:31:57

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

【KAIXIN】 · 发表于 2013-1-27 08:16:49

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

基本上可以了，

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

阿然 · 发表于 2013-1-27 23:05:41

好吧，不纠结外框形状了

请重新下载fas测试

hhhlike · 发表于 2013-1-28 08:27:30

然兄高手，这个功能不错

阿然 · 发表于 2013-1-28 10:01:21

本帖最后由阿然于 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))
(setq objlength (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 data datalst
(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)
(setq arraySpace
(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)
(setq arraySpace
(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)
(setq arraySpace
(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
)

(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)) 
  (setq  objlength (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 data  datalst 
    (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) 
  (setq  arraySpace 
   (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) 
  (setq  arraySpace 
   (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) 
  (setq  arraySpace 
   (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 
)

qianzj · 发表于 2013-1-28 15:28:10

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

很厉害下来学习!

asd19400 · 发表于 2013-5-24 00:13:51

传说中的APS

账号		自动登录	找回密码
密码			注册

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

本帖子中包含更多资源

评分

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源

点评

评分