[分享]：★★★★★沿某方向阵列复制功能，高手帮忙改善一下。

userzhluserzhl

;★沿某方向阵列复制_[源自海龙工具箱 zhl-soft.ys168.com 20090218]
(defun c:zhl_cv ( / #copy a ang dbasepoint dist distp dtopoint eastp entcopy input item msg n northp operation orthm p0 p1 p2 sent snapa southp sslist westp)
(setvar "CMDECHO" 0)
(defun DynArray_go ( NP / entcopy )
(vl-cmdf "._copy" item "" Dbasepoint P0)
(setq entcopy (entlast))
(setq SSlist (append SSlist (list entcopy)))  
)
(defun DarrayOrthoMode0 ()
(setq input (grread t 4 4))
(setq DtoPoint (cadr input))
)
(defun DarrayOrthoMode1 (/ distP NorthP WestP EastP SouthP)
    (setq distP (distance Dbasepoint DtoPoint))
    (setq NorthP (polar Dbasepoint (+ snapA (dtr 90)) distP))
    (setq WestP  (polar Dbasepoint (+ snapA (dtr 180)) distP))
    (setq EastP  (polar Dbasepoint snapA distP))
    (setq SouthP (polar Dbasepoint (- snapA (dtr 90)) distP))
(if (and
      (< (distance DtoPoint NorthP) (distance DtoPoint WestP))
      (< (distance DtoPoint NorthP) (distance DtoPoint EastP))
      (< (distance DtoPoint NorthP) (distance DtoPoint SouthP))
    )
(setq DtoPoint NorthP)
)
(if (and
      (< (distance DtoPoint WestP) (distance DtoPoint NorthP))
      (< (distance DtoPoint WestP) (distance DtoPoint EastP))
      (< (distance DtoPoint WestP) (distance DtoPoint SouthP))
    )
(setq DtoPoint WestP)
)  
(if (and
      (< (distance DtoPoint EastP) (distance DtoPoint WestP))
      (< (distance DtoPoint EastP) (distance DtoPoint NorthP))
      (< (distance DtoPoint EastP) (distance DtoPoint SouthP))
    )
(setq DtoPoint EastP)
)
(if (and
      (< (distance DtoPoint SouthP) (distance DtoPoint WestP))
      (< (distance DtoPoint SouthP) (distance DtoPoint EastP))
      (< (distance DtoPoint SouthP) (distance DtoPoint NorthP))
    )
(setq DtoPoint SouthP)
)  
)
(defun dtr (a)
(* pi (/ a 180.0))
)
(defun rtd (a)
(/ (* a 180) pi)
)
  (defun *error* (msg)
    (if        SSlist
      (progn
        (foreach n SSlist
          (vl-cmdf "._explode" n)
        )
        (setq SSlist nil)
      )
    )
(if _{DarrayBlock}_
(progn
    (vl-cmdf "._explode" item)
    (vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
  )))
(if _{DarrayBlock}_
(vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
)
  (setq sent (ssget))
  (setq p1 (getpoint "\n复制的起点:"))
  (setq p2 (getpoint p1 "\n复制的终点(输入距离或点取):"))
  (setq Dbasepoint p1)
  (vla-StartUndoMark
    (vla-get-ActiveDocument (vlax-get-ACAD-Object))
  )
  (vl-cmdf "._-block" "_{DarrayBlock}_" Dbasepoint sent "")
  (vl-cmdf "._-insert" "_{DarrayBlock}_" Dbasepoint "" "" "")
  (setq item (entlast))
(setq snapA (getvar "snapang"))
(setq orthm (getvar "ORTHOMODE"))
  (while (or
           (and (setq input (grread t 4 4))(= (car input) 5))
           (and (= (car input) 2) (= (cadr input) 15))          ; F8 Orthomode                  
         )
(setq P0 p1)
(if (= (car input) 5) (setq DtoPoint (cadr input)))
(if (and (= (car input) 2)(= (cadr input) 15))
  (setq Operation "ORTHO")
)
(if (eq Operation "ORTHO")
  (progn
    (if (eq orthm 1)
      (progn (setvar "ORTHOMODE" 0) (setq orthm 0))
      (progn (setvar "ORTHOMODE" 1) (setq orthm 1))
         )
    (setq Operation nil)
  )
)
(if (eq orthM 1)
  (DarrayOrthoMode1)
)      
    (setq ang (angle p1 p2))
(setq #Copy ( + 1 (fix (/ (distance Dbasepoint DtoPoint) (distance p1 p2)))) )
    (setq dist (distance p1 p2))
    (if        SSlist
      (progn
        (foreach n SSlist
          (vl-cmdf "._erase" n "")
          (princ)
        )
        (setq SSlist nil)
      )
    )
    (repeat (1- #Copy)
      (setq P0 (polar P0 ang dist))
      (DynArray_go P0)
      (princ)
    )
  )
(redraw)
  (if SSlist
    (progn
      (foreach n SSlist
        (vl-cmdf "._explode" n)
      )
      (setq SSlist nil)
    )
  )
  (vl-cmdf "._explode" item)
  (vl-cmdf "._-purge" "_B" "_{DarrayBlock}_" "_N")
  (vla-EndUndoMark
    (vla-get-ActiveDocument (vlax-get-ACAD-Object))
  )
  (princ)
)
哪位高手帮忙改善一下：
如果执行此功能中途按ESC的话不会执行(vl-cmdf "._explode" item)
还有就是(redraw)，如果物体较多的话会很慢，可不可以：点击左键才(redraw)，点击右键才是确定呢？

carrot1983

我也有个类似的。。。
方向递增。。。
要不要给你参考参考

userzhluserzhl

太好了，可不可以发到我邮箱里？
user-zhl@163.com，谢谢！

carrot1983

不行。。。
你都出自己的工具箱了

楼主也算不错的啦。

看完动画应该就知道怎么写了。。。

呵呵

偶只是给你提供个思路。

userzhluserzhl

命令CV

露水2

我也有个

userzhluserzhl

我的这个就是(redraw)，很慢。