我这有个跟你差不多的，复制次数是有记忆功能的
 - (defun c:cs ( / cc_st callong cc_corsleft cc_cors Distcc_key )
- (princ "单向阵列")
- (setq *error* ss_err)
- (SETQ OS (GETVAR "OSMODE"))
- (setq cc_get (ssget ))
- (setvar "cmdecho" 0 )
- (command "undo" "be")
- (initget 1)
- (setq cc_pt (getpoint "\n基点:"))
- (initget 1 "Big Small Distcc")
- (setq cc_cor (getpoint cc_pt "\n输入距离或[计算距离(D)]:"))
- (cond ((= cc_cor "Big")(setq cc_cor(polar cc_pt 0 126.8)))
- ((= cc_cor "Small")(setq cc_cor(polar cc_pt 0 101.4)))
- ((= cc_cor "Distcc")
- (progn
- (setq Distcc_key 0)
- (setq cc_time (getint "\n复制次数:"))
- (setq cc_cor (getpoint cc_pt "\n选取距离:"))
- )))
- (if (= Distcc_key 0)
- (cs_caldist)
- (cs_caltime)
- )
- (prin1)
- )
- (defun cs_caldist ( )
- (setq alldist(distance cc_pt cc_cor))
- (setq eachdist(/ alldist cc_time))
- (setq td(mapcar '- cc_cor cc_pt))
- (setq eachtd(mapcar '(lambda(n)(/ n cc_time)) td) )
- (setq i 1)
- ;(setq cc_cors (mapcar '+ cc_pt (mapcar '(lambda(n)(* 1 n)) eachtd)) )
- (repeat cc_time
- (setq cc_cors (mapcar '+ cc_pt (mapcar '(lambda(n)(* i n)) eachtd)) )
- (ost)
- (command "copy" cc_get "" cc_pt cc_cors ) (ose)
- (setq i(1+ i))
- ;(setq cc_cors(mapcar '+ cc_cors eachtd))
- )(prin1)
- )
- (defun cs_caltime ( )
- (if (/= cc_Ttime nil)(setq cc_Ttime cc_time)
- (setq cc_Ttime 1)
- )
- (setq cc_cors cc_cor)
- (mapcar 'princ (list "\n复制次数或[自动计算(C)]<" cc_Ttime ">:" ))
- (initget "Cal")
- (setq cc_time (getint ))
- (if (= cc_time nil )(setq cc_time cc_Ttime))
- (setq cc_corsleft (mapcar '- cc_cor cc_pt))
- (if (= cc_time "Cal")
- (progn (setq callong(getdist "\n选取总距离:"))
- (setq cc_time (fix(/ callong (distance cc_pt cc_cor)))))
- )
- (setq cc_st 0)
- (while (/= cc_st cc_time )
- (progn
- (SETVAR "OSMODE" 0)
- (command "copy" cc_get "" cc_pt cc_cors )
- (SETVAR "OSMODE" OS)
- (setq cc_cors (mapcar '+ cc_corsleft cc_cors))
- (setq cc_st (+ 1 cc_st)))
- )
- (command "undo" "e")
- (if (numberp cc_time)
- (setq cc_Ttime cc_time))
- (setvar "cmdecho" 1 )
- (prin1)
- )
| 
发表于 2014-7-10 11:20:17
置顶卡
变色卡
显身卡
发表于 2014-7-10 15:35:25
楼主