给新手练手--快速动态阵列（单向）

print1985 · 发表于 2021-3-2 00:21:03

本帖最后由 print1985 于 2021-3-2 11:40 编辑

快速动态阵列（单向），程序比较好玩，也很实用
代码有大量注释（;后为代码注释），新手可以用来练手
觉得有用的可以点个赞

，谢谢~~

部分代码来自论坛，感谢各位大神
技术含量不高，但是水平有限错误难免，如有问题请留言

;快速动态阵列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 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 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)
)

;快速动态阵列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 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 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:25:39

本帖最后由 1028695446 于 2021-5-31 23:36 编辑

整合LEE MAC大神的GRTEXT函数，随光标动态显示已复制次数

luyu9635 · 发表于 2021-3-3 10:46:06

和这个差不多，这是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")

;;; 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")

ninja37 · 发表于 2022-10-26 21:56:04

甘大师，这个程序很好用，最近我遇到麻烦，有一个很好的想法，目前找遍了论坛还没有类似的功能，我们这个行业有时候一个零件需要做好几个，需要连续复制，但是零件都是要有间距的，目前还没有等间距的复制功能，大概意思是这样的，选择一个图元然后会提示输入间距是多少，然后连续复制，（举个例子，复制10mm*10mm的方块输入命令，选择10*10矩形，提示间距是多少，比如输入2，然后复制矩形每一个距离是12mm,只需要支持横着或者竖着复制，任何按横竖的方向复制，按一下空格就复制一个esc取消）

tigcat · 发表于 2021-3-2 10:50:42

一看注释就慌神了。最怕注释比例太多，卡

print1985 · 发表于 2021-3-2 10:56:34

tigcat 发表于 2021-3-2 10:50
一看注释就慌神了。最怕注释比例太多，卡

我晕不是cad注释是代码的注释。。。就是备注代码的作用

vitalgg · 发表于 2021-3-2 21:00:38

对比一下天正的功能。

tigcat · 发表于 2021-3-2 22:02:53

print1985 发表于 2021-3-2 10:56
我晕不是cad注释是代码的注释。。。就是备注代码的作用

那就不怕了，我好好看看。

print1985 · 发表于 2021-3-3 16:59:56

luyu9635 发表于 2021-3-3 10:46
和这个差不多，这是chenqj写的，大家可以对比下，看哪个更适合自己

试用了一下他是用的矩阵大量的VL高级函数我完全不会但是有个问题他一直在循环复制阵列对象稍微多一点就非常卡甚至卡很久阵列同样多的对象你可以对比一下2个程序的速度。

luyu9635 · 发表于 2021-3-7 16:55:22

print1985 发表于 2021-3-3 16:59
试用了一下他是用的矩阵大量的VL高级函数我完全不会但是有个问题他一直在循环复制阵列对象稍微多一 ...

您说的对，对象多时他这个会很卡，你的不会，少的时候不会卡，您的程序我建议改成两点（跟原始命令一样），不要另外去量取距离了，省一个步骤，更符合用户习惯一点

print1985 · 发表于 2021-3-7 22:35:49

luyu9635 发表于 2021-3-7 16:55
您说的对，对象多时他这个会很卡，你的不会，少的时候不会卡，您的程序我建议改成两点（跟原始命令一样） ...

不懂你的意思
程序本来就是只选择2个点开始阵列啊并没有多余的量取距离起点和终点既是方向也是距离和你发的程序一样的不知道你想要什么样的

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

[源码] 给新手练手--快速动态阵列（单向）

评分

本帖子中包含更多资源

点评