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

[分享]★★★★★沿某方向阵列复制功能，高手帮忙改善一下。
www.dimcax.com
[分享]★★★★★沿某方向阵列复制功能，高手帮忙改善一下。;★沿某方向阵列复制_[源自海龙工具箱 zhl-soft.ys168.com
(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)，点击右键才是确定呢？
【好评】 支持原创，鼓励源码 明经币+1 金钱+5 经验+5 [caoyin |
d