[原创]一个好用的连续复制程序

langjs 发表于 2009-4-27 21:41:00

;;;__________________________________________ ;;; 连续复制 ;;;__________________________________________ (defun c:v(/ oce ss p1 p2) (setq oce(getvar "cmdecho")) (setvar "cmdecho" 0) (setq ss (ssget)) (if (null ss) (exit)) (setq p0(getpoint"\n指定基点:")) (setq p2 p0) (if (null p0 )(exit)) (princ "\n指定第二点或位移:") (while t (setq p1(getpoint p0)) (if (null p1) (mosi11) (mosi12)) ) (princ) ) (defun mosi12() (command ".copy" ss "" "m" p2 p1 "") (setq juli (distance p0 p1)) (setq  x0 (car p0)) (setq  y0 (cadr p0)) (setq p0 p1) (setq  x1 (car p1)) (setq  y1 (cadr p1)) (setq  x (- x1 x0)) (setq  y (- y1 y0)) (setq   hudu(atan y x) ) (setq  x1 (+ x0 x)) (setq  y1 (+ y0 y)) (setq  p1 (list x1 y1 0.0)) (princ (strcat "\n指定下一点或继续位移<" (rtos juli ) ">:")) )(defun mosi11()       (setq p1 (list (+ (nth 0 p0) (* juli (cos hudu)))                      (+ (nth 1 p0) (* juli (sin hudu)))                      (nth 2 p0)                )       ) (command ".copy" ss "" "m" p2 p1 "") (setq juli (distance p0 p1)) (setq p0 p1) (princ (strcat "\n指定下一点或继续位移<" (rtos juli ) ">:")) )

zmzk 发表于 2022-12-10 09:17:43

;p这个笑脸代表什么啊？程序少东西

langjs 发表于 2009-4-27 21:54:00

再奉献一个程序;;;__________________________________________ ;;;  文字、数字递增加1复制 ;;;__________________________________________ (defun c:MR(/ oce ss p1 p2) (setq oce(getvar "cmdecho")) (setvar "cmdecho" 0) (setq ent (car (entsel "\n递增复制:\n选起始文字:"))) (if (null ent) (exit)) (setq p0(getpoint"\n指定基点:")) (if (null p0 )(exit)) (princ "\n指定第二点或位移:") (while t (setq p1(getpoint p0)) (if (null p1) (mosi111) (mosi112)) ) (princ) ) (defun mosi112() (command ".copy" ent "" "m" p0 p1 "") (setq juli (distance p0 p1)) (setq ent (entlast)) (DS) (setq  x0 (car p0)) (setq  y0 (cadr p0)) (setq p0 p1) (setq  x1 (car p1)) (setq  y1 (cadr p1)) (setq  x (- x1 x0)) (setq  y (- y1 y0)) (setq   hudu(atan y x) ) (setq  x1 (+ x0 x)) (setq  y1 (+ y0 y)) (setq  p1 (list x1 y1 0.0)) (princ (strcat "\n指定下一点或继续位移<" (rtos juli ) ">:")) )(defun mosi111()       (setq p1 (list (+ (nth 0 p0) (* juli (cos hudu)))                      (+ (nth 1 p0) (* juli (sin hudu)))                      (nth 2 p0)                )       ) (command ".copy" ent "" "m" p0 p1 "") (setq ent (entlast)) (DS) (setq juli (distance p0 p1)) (setq p0 p1) (princ (strcat "\n指定下一点或继续位移<" (rtos juli ) ">:")) )(defun DS( ) (setq txt1 (entget ent)) (setq txt1 (cdr (assoc 1 txt1))) (setq aa (atoi txt1)) (if (and (> aa 0 ) (= (itoa aa) txt1 ) ) (tj120 ) (tj110 ) ) (princ) ) (defun tj110( / mm zz pp txt2 kk txt3) (setq mm (strlen txt1)) (setq zz mm ) (while (or (> (atoi (substr txt1 zz )) 0) (= (substr txt1 zz zz ) "0" )) (setq zz (- zz 1)) ) (setq pp (substr txt1 (+ zz 1) )) (setq txt2 (substr txt1 1 zz )) (setq kk (atoi pp) ) (setq kk (+ kk 1 )) (setq txt3 (strcat txt2 (itoa kk))) (setq ent (entget ent)) (setq ent (subst (cons 1 txt3 ) (assoc 1 ent) ent) ) (entmod ent) (setq ent (cdr (assoc -1 ent))) (princ) ) (defun tj120 ( / txt2 num txt3) (setq num 0 ) (setq txt2 (atoi txt1))(setq num (+ num 1 )) (setq txt3 ( + txt2 num) ) (setq ent (entget ent)) (setq ent (subst (cons 1 (itoa txt3) ) (assoc 1 ent) ent) ) (entmod ent) (setq ent (cdr (assoc -1 ent))) (princ) )

ayunger 发表于 2009-4-28 01:40:00

;;;******************************** ;;; No.9-2  动态复制函数          ;;;  -By Ayunger Studio 2009.04.27 ;;;******************************** (defun c:ayDCopy (/ SS1 isFirst xAng xDist Pt0 Pt1 Pt2)  (vl-load-com)  (vl-cmdf "_.UNDO" "BE")  (while (not (setq SS1 (ssget))))  (initget 1)  (setq Pt0 (getpoint "\n指定基点: "))  (setq Pt2 Pt0)    (setq isFirst T)  (while T   (if isFirst    (progn     (initget 1)     (setq Pt1 (getpoint Pt2 "\n指定第二点: "))    );end_progn    (setq Pt1 (getpoint Pt2 (strcat "\n指定下一点或位移<" (rtos xDist 2) ">: ")));else   );end_if   (setq isFirst nil)      (ayOSMode nil);关闭捕捉.   (if Pt1    (progn;then     (vl-cmdf "_.Copy" SS1 "" "M" Pt0 Pt1 "")     (setq xDist (distance Pt2 Pt1))     (setq xAng (angle Pt2 Pt1))    );end_progn        (progn;else     (setq Pt1 (polar Pt2 xAng xDist))     (vl-cmdf "_.Copy" SS1 "" "M" Pt0 Pt1 "")    );end_progn   );end_if   (ayOSMode T);打开捕捉.   (setq Pt2 Pt1)  );end_while  (vl-cmdf "_.UNDO" "E")  (princ) );end_defun;;;************************** ;;; No.0 对象捕捉开关函数   ;;;************************** (defun ayOSMode (isOpenSnap)  (if isOpenSnap   (setvar "osmode" (rem (getvar "osmode") 16384));打开捕捉.   (setvar "osmode" (+ (rem (getvar "osmode") 16384) 16384));关闭捕捉.  );end_if );end_defun

langjs 发表于 2009-4-28 09:00:00

感谢楼上指点，比我编的好多了。另外如果程序能象普通的复制那样显示拖动效果就更好了，小弟入行浅，想了好久也不知道怎么达到拖动效果，可否指点一二？

AMTONNY 发表于 2009-4-28 22:18:00

看偶调用原命令(defun c:CC ()   (setvar "cmdecho" 0)       (princ "\n--->>>连续复制")       (SETQ SS(SSGET))       (command "_.copy" ss "" "m") (princ))

langjs 发表于 2009-4-29 17:16:00

本帖最后由 langjs 于 2011-12-24 22:54 编辑 修改一下，象普通复制那样带拖动效果了。编的有点乱，莫见笑。
;;; __________________________________________ ;;; 连续复制     langjs 2009.4.29 ;;; __________________________________________ (defun c:lxfz ( / ennn hudu juli julibak oce p0 p1 ss ssbak)   (setq oce (getvar "cmdecho"))   (setvar "cmdecho" 0)   (vl-load-com)   (setq ss (ssget))   (if (null ss)     (vl-exit-with-error "")   )   (setq p0 (getpoint "\n指定基点:"))   (if (null p0)     (vl-exit-with-error "")   )   (princ "\n指定第二点, 或位移:")   (while t     (command ".UNDO" "BE")     (setq ennn (entlast))     (command ".copy" ss "" p0 pause)     (setq p1 (getvar "lastpoint"))     (setq ss (lt:ss-entnext ennn))     (setq juli (distance p0 p1))     (if (= 0 juli)       (progn  (command ".erase" ss "")  (setq ss ssbak)  (setq p1 (list (+ (nth 0 p0) (* julibak (cos hudu))) (+ (nth 1 p0) (* julibak (sin hudu))) (nth 2 p0)))  (setq ennn (entlast))  (command ".copy" ss "" p0 p1)  (setq ss (lt:ss-entnext ennn))  (setq ssbak ss)  (setq p0 p1)  (princ (strcat "\n指定下一点, 或继续位移<" (rtos julibak) ">:"))       )       (progn  (setq ssbak ss)  (setq julibak juli)  (setq hudu (angle p0 p1))  (princ)  (setq p0 p1)  (princ (strcat "\n指定下一点, 或继续位移<" (rtos julibak) ">:"))       )     )     (command ".UNDO" "E")     (princ)   )   (princ) ) ;;; _____________________________________________________________ ;;; ▓ (lt:ss-entnext en) ;;; [功能] 获取在图元 en 之后产生的图元的选择集 ;;; [参数] en----图元名 ;;; [返回] 选择集 ;;; [测试]1.(setq en (entlast)) ;;;         执行创建图元的命令，如 line,boundary ;;;         (setq ss (lt:ss-entnext en)) ;;;       2.(setq ss (lt:ss-entnext (car(entsel)))) (defun lt:ss-entnext (en / ss)   (if en     (progn       (setq ss (ssadd))       (while (setq en (entnext en))  (if (not (member (cdr (assoc 0 (entget en))) '("ATTRIB" "VERTEX"      "SEQEND"     )    )      )    (ssadd en ss)  )       )       (if (zerop (sslength ss))  (setq ss nil)       )       ss     )     (ssget "_x")   ) )

userzhl 发表于 2009-4-29 18:10:00

结束处理得不好.最好可以这样:接空格就结束,按右键才继续复制.

langjs 发表于 2009-4-30 11:59:00

有时候点击快了，拷贝的位置出现错误，不知哪位老大能指点指点迷津？

caoyin 发表于 2009-5-1 09:03:00

指定下一点, 或继续位移<1568.5362>: 未知命令“V”。按 F1 查看帮助。程序运行有点慢哦，而且还有错误

lzj511 发表于 2009-5-7 21:29:00

CAD2008里面的copy本身就可以连续复制啊!!

页: [1] 2

明经CAD社区's Archiver

[原创]一个好用的连续复制程序