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

userzhl

;★沿某方向阵列复制_[源自海龙工具箱 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)，点击右键才是确定呢？