给新手练手--快速动态阵列（单向）
本帖最后由 print1985 于 2021-3-2 11:40 编辑快速动态阵列（单向），程序比较好玩，也很实用
代码有大量注释（;后为代码注释），新手可以用来练手
觉得有用的可以点个赞:lol，谢谢~~
部分代码来自论坛，感谢各位大神
技术含量不高，但是水平有限错误难免，如有问题请留言
http://bbs.xdcad.net/data/attachment/forum/202103/02/113439vh5vm3t8z1hb4yx1.gif
;快速动态阵列zz
;为防止卡顿最多阵列100次，完全够用了
(vl-load-com)
(defun c:zz ( / *error* ang copy-fx copyn dist dist-x dist-y end-pt eraseyn gbydjl-x gbydjl-y i lastent m msg ms-pt ms-pt-x ms-pt-y p1 p2 pt pt-x pt-y snap ss sslst ss-new)
(defun *error* (msg);错误处理函数
(if snap (setvar "osmode" snap)) ;恢复捕捉
(if (< 18 (atoi (substr (getvar "acadver") 1 2))) ;判断CAD版本，高版本用command-s
(command-s "undo" "e") ;CAD高版本用
(command "undo" "e") ;低版本用
)
(setvar "cmdecho" 1) ;打开命令行提示
(princ msg)
)
(if (setq ss (ssget))
(progn
(setvar "cmdecho" 0) ;关闭命令行提示
(vl-cmdf "undo" "be") ;命令开始标记
(setq snap (getvar "osmode")) ;取得捕捉参数
(if (setq p1 (getpoint "\n点取复制的起点:"))
(if (setq p2 (getpoint p1 "\n点取或输入复制距离:"))
(progn
(setq dist (distance p1 p2) ;复制距离
dist-x (abs (- (car p1) (car p2))) ;x轴复制距离
dist-y (abs (- (cadr p1) (cadr p2))) ;y轴复制距离
ang (angle p1 p2)
end-pt p1 ;终点
pt p2 ;光标移动距离判断基准值
i 0;最大阵列/复制次数
m T;提示超100个，只提示一次，防止卡顿
)
(if (> dist-x dist-y);复制X/Y大方向判断
(if (< (car p1) (car p2))
(setq copy-fx "x+") ;X+方向
(setq copy-fx "x-") ;X-方向
)
(if (< (cadr p1) (cadr p2))
(setq copy-fx "y+") ;y+方向
(setq copy-fx "y-") ;y-方向
)
)
(while
(or (and (setq ms-pt (grread t 4 4)) (= (car ms-pt) 5))
(and (= (car ms-pt) 2) (= (cadr ms-pt) 15))
)
(setq ms-pt-x(car (cadr ms-pt));当前光标x坐标
ms-pt-y(cadr (cadr ms-pt)) ;当前光标y坐标
pt-x (car pt)
pt-y (cadr pt)
gbydjl-x (abs (- ms-pt-x pt-x)) ;x轴光标移动距离
gbydjl-y (abs (- ms-pt-y pt-y)) ;y轴光标移动距离
)
(cond;复制/删除次数
((= copy-fx "x+")
(progn
(setq copyn (fix (/ gbydjl-x dist-x)))
(setq eraseyn (- ms-pt-x pt-x))
)
)
((= copy-fx "x-")
(progn
(setq copyn (fix (/ gbydjl-x dist-x)))
(setq eraseyn (- pt-x ms-pt-x))
)
)
((= copy-fx "y+")
(progn
(setq copyn (fix (/ gbydjl-y dist-y)))
(setq eraseyn (- ms-pt-y pt-y))
)
)
((= copy-fx "y-")
(progn
(setq copyn (fix (/ gbydjl-y dist-y)))
(setq eraseyn (- pt-y ms-pt-y))
)
)
)
(if (and (> copyn 0) (< copyn 100) (> eraseyn 0));复制对象
(progn
(setvar "osmode" 0) ;关闭捕捉
(repeat copyn
(if (and (< i 100) (>= i 0))
(progn
(setq end-pt (polar end-pt ang dist)) ;终点
(setq pt (polar end-pt ang dist))
(setq lastent (entlast))
(vl-cmdf "copy" ss "" p1 end-pt) ;复制
(while (/= 0 (getvar "cmdactive")) (command pause)) ;等待命令完成
(setq ss-new (ent_from lastent)) ;复制后新产生的图元选择集
(setq sslst (append sslst (list ss-new)))
(setq i (length sslst))
)
(if (and (> i 99) m)
(progn
(setq m nil)
(princ "\n一次复制对象超过100个，为防止卡死，已停止复制!")
)
)
)
)
(setvar "osmode" snap) ;打开捕捉
)
(if (and (> i 99) m)
(progn
(setq m nil)
(princ "\n一次复制对象超过100个，为防止卡死，已停止复制!")
)
)
)
(if (and (> copyn 0) (< eraseyn 0) sslst (>= i 0));删除对象
(progn
(if (not m)
(princ "\n") ;换行
)
(repeat copyn
(if (and (< i 101) (>= i 0) sslst)
(progn
(setq pt end-pt)
(setq end-pt (polar end-pt (+ ang pi) dist))
(vl-cmdf "erase" (car (reverse sslst)) "") ;删除
(while (/= 0 (getvar "cmdactive")) (command pause)) ;等待命令完成
(setq sslst (reverse (nth_del (reverse sslst) 0)))
(setq i (length sslst))
(setq m T)
)
)
)
)
)
)
)
)
)
(vl-cmdf "undo" "e") ;命令结束标记
(setvar "cmdecho" 1) ;打开命令行提示
)
)
(princ)
)
;返回新产生图元选择集-来自论坛
(defun ent_from (e / ss sn)
(if (/= (type e) (quote ename))
(alert "parameter error in ent_from")
)
(setq ss (ssadd))
(while e
(setq e (entnext e))
(if e
(progn
(setq sn (cdr (assoc 0 (entget e))))
(if (not (member sn (quote ("ATTRIB" "VERTEX" "SEQEND"))))
(setq ss (ssadd e ss))
)
)
)
)
ss
)
;删除表内第n个元素-来自论坛
(defun nth_del (lst n)
(vl-remove-if '(lambda (x) (= (vl-position x lst) n)) lst)
)
本帖最后由 1028695446 于 2021-5-31 23:36 编辑
整合LEE MAC大神的GRTEXT函数，随光标动态显示已复制次数 和这个差不多，这是chenqj写的，大家可以对比下，看哪个更适合自己
;;; the following code are writen by qjchen ;
;;; Purpose: To dynamic copy Object in one way ;
;;; Thanks to: lushui2 (The original idea Author) ;
;;; Andera (He post a very cool Dynamic Array rountine) ;
;;; at http://www.theswamp.org/index.php?topic=26633.5 ;
;;; Version v 1.0 2011.03.15 ;
;;; Http://chenqj.blogspot.com ;
;;; ========================================================================
;;; =======================================================================;
;;; The main function ;
;;; =======================================================================;
(vl-load-com)
(defun c:zf ( / dir gr nx p0 px pxv ss ss1 vecx)
(setq ss (std-sslist (ssget))
p0 (getpoint "\n指定基点:") px (getpoint p0 "\n指定下一点:")
vecx (mapcar '- px p0)
)
(prompt "\nThe end point:")
(while (= (car (setq gr (grread nil 5 0))) 5)
(if ss1 (q:ss:del ss1))
(redraw)
(setq pxv (mapcar '- (inters (cadr gr) (polar (cadr gr) (+ (/ pi 2.0) (angle px p0)) 1.0) p0 px nil) p0))
(if (< (setq nx(fix (/ (caddr (trans pxv 0 vecx)) (caddr (trans vecx 0 vecx))))) 0)
(setq dir -1 nx (- nx)) (setq dir 1))
(setq ss1 (q:ss:dyngen ss nx vecx dir))
(grdraw p0 (mapcar '+ p0 pxv) 3 1)
)
(princ)
)
;;; =======================================================================;
;;; by qjchen, copy ss according to the direction and vector ;
;;; =======================================================================;
(defun q:ss:dyngen (sslst n v dir / i matlist obj1 ss transmat xobj)
(setq ss (ssadd))
(foreach x sslst
(setq xobj (vlax-ename->vla-object x) i 1)
(repeat n
(setq obj1 (vla-copy xobj)
matList (list (list 1 0 0 (* i (car v) dir)) (list 0 1 0 (* i (cadr v) dir)) '(0 0 1 0) '(0 0 0 1))
transmat (vlax-tmatrix matlist))
(vla-transformby obj1 transMat)
(ssadd (vlax-vla-object->ename obj1) ss)
(setq i (1+ i))
)
)
ss
)
;;; =======================================================================;
;;; by qjchen, entdel ss ;
;;; =======================================================================;
;; (setq a (ssget)) ;
;; (q:ss:del a) ;
;;; =======================================================================;
(defun q:ss:del (ss / i)
(setq i 0)
(repeat (sslength ss)
(entdel (ssname ss i))
(setq i (1+ i))
)
)
;;; =======================================================================;
;;; by qjchen, 2 ss add ;
;;; =======================================================================;
(defun q:ss:add (ss1 ss2 / i)
(setq i -1)
(repeat (sslength ss2)
(setq i (1+ i))
(setq ss1 (ssadd (ssname ss2 i) ss1))
)
ss1
)
;;; =======================================================================;
;;; selection to list, by Reini Urban ;
;;; =======================================================================;
(defun std-sslist(ss / n lst)
(if (eq 'pickset (type ss))
(repeat (setq n (fix (sslength ss))) ; fixed
(setq lst (cons (ssname ss (setq n (1- n))) lst))))
)
(princ "by qjchen@gmail.com, To dynamic Array object, the command is Test") 甘大师，这个程序很好用，最近我遇到麻烦，有一个很好的想法，目前找遍了论坛还没有类似的功能，我们这个行业有时候一个零件需要做好几个，需要连续复制，但是零件都是要有间距的，目前还没有等间距的复制功能，大概意思是这样的，选择一个图元然后会提示输入间距是多少，然后连续复制，（举个例子，复制10mm*10mm的方块输入命令，选择10*10矩形 ，提示间距是多少，比如输入2，然后复制矩形每一个距离是12mm,只需要支持横着或者竖着复制，任何按横竖的方向复制，按一下空格就复制一个esc取消） 一看注释就慌神了。最怕注释比例太多，卡 tigcat 发表于 2021-3-2 10:50
一看注释就慌神了。最怕注释比例太多，卡
我晕 不是cad注释 是代码的注释。。。就是备注代码的作用 http://atlisp.cn/static/draw-car.gif
对比一下天正的功能。 print1985 发表于 2021-3-2 10:56
我晕 不是cad注释 是代码的注释。。。就是备注代码的作用
那就不怕了，我好好看看。 luyu9635 发表于 2021-3-3 10:46
和这个差不多，这是chenqj写的，大家可以对比下，看哪个更适合自己
试用了一下 他是用的矩阵 大量的VL高级函数 我完全不会 但是有个问题 他一直在循环复制 阵列对象稍微多一点就非常卡 甚至卡很久 阵列同样多的对象 你可以对比一下2个程序的速度。
print1985 发表于 2021-3-3 16:59
试用了一下 他是用的矩阵 大量的VL高级函数 我完全不会 但是有个问题 他一直在循环复制 阵列对象稍微多一 ...
您说的对，对象多时他这个会很卡，你的不会，少的时候不会卡，您的程序我建议改成两点（跟原始命令一样），不要另外去量取距离了，省一个步骤，更符合用户习惯一点 luyu9635 发表于 2021-3-7 16:55
您说的对，对象多时他这个会很卡，你的不会，少的时候不会卡，您的程序我建议改成两点（跟原始命令一样） ...
不懂你的意思
程序本来就是只选择2个点开始阵列啊 并没有多余的量取距离 起点和终点 既是方向也是距离 和你发的程序一样的 不知道你想要什么样的