【源码分享之自由系列1】可代替copy的自由复制程序--------V1.8版
本帖最后由 wowan1314 于 2014-11-6 12:20 编辑程序实现COPY过程中动态的进行镜像、旋转、放大、缩小、对齐、改基点、改转角及记忆复制。
程序现在已基本成型。 以后不会更新了！
如果有朋友完善或扩展了此程序。也请发至论坛,以便大家学习，敬谢！！
=========特别鸣谢G版=====================;;;==================={ 自由复制V1.1 BY wowan1314 }================================
;;;功能：实现复制的过程中镜像、旋转、放大、缩小、修改复制基点。
;;;程序目标：在我的工作中取代CAD的复制命令
;;; 特别鸣谢 G版
;;;程序难点、复杂点均参考自G版的"带捕捉的GRREAD函数"-----
;;;程序的完善也将继续大抄特抄G版的代码，在此表示由衷的感谢。
(DEFUN C:YY-COPY (/ SSPT SIZE OLDOSBB PT1
NEARPT G2H D LST PTX PTY
PTT1 PTT2PTT3 PTT4 AERROR Aerror_end
olderr
)
(defun Aerror(x)
(Aerror_end)
(AND olderr (COMMAND "ERASE" SS ""))
)
(defun Aerror_end ()
(ifoldos
(setvar "osmode" oldos)
)
(ifoldCM
(setvar "cmdecho" oldCM)
)
(command "_.undo" "e")
(REDRAW)
(prinC)
)
(IF (SETQ SS (SSGET ":L"))
(SETQ PT(getpoint "\n选择复制基点:")
pt1 pt
)
)
(IF (AND SS PT)
(PROGN
(setq olderr*error*
*error* Aerror
)
(setq size (* (getvar "viewsize") 2))
(setq oldos (getvar "osmode")
oldCM (getvar "cmdecho")
)
(setvar "osmode" 0)
(setvar "cmdecho" 0)
(command "_.undo" "be")
(WHILE pt1
(setq pt pt1)
(command "_.copy" SS "" "0,0" "@")
(PRINC
"\n点取位置或 [转90度(A)/左右翻(D)/上下翻(S)/改转角()/改基点(T)]<退出>"
)
(while PT
(setq BB (grread T 5 1))
(cond
((= (car BB) 5)
(SETQ PT1 (CADR BB))
(redRaw)
(gxl-Sel-ReDrawSel SS 2)
(if
(setq
nearpt(osnap PT1 "_ENDP,_MID,_INT,NEA")
) ; 取得的捕捉点,端点，中点，交点
(PROGN
(setq g2 nearpt)
(setqh (/ (getvar "viewsize")
(cadr (getvar "screensize"))
)
d (getvar "pickbox")
lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h))
ptx (car g2)
pty (cadr g2)
)
(foreach x lst
(setq ptt1 (list (- ptx x) (- pty x))
ptt2 (list (+ ptx x) (- pty x))
ptt3 (list (+ ptx x) (+ pty x))
ptt4 (list (- ptx x) (+ pty x))
)
(grvecs
(list 2 ptt1 ptt2 ptt2 ptt3 ptt3 ptt4 ptt4 ptt1)
)
)
(setq pt1 g2)
)
)
(GRVECS
(LIST 1314
PT1
(mapcar '+ (LIST size 0 0) PT1)
1314
PT1
(mapcar '- PT1 (LIST size 0 0))
1314
PT1
(mapcar '- PT1 (LIST 0 size 0))
1314
PT1
(mapcar '+ (LIST 0 size 0) PT1)
)
)
(gxl-Sel-ReDrawSel SS 1)
(COMMAND "MOVE" SS "" PT PT1)
(SETQ PT PT1)
)
((= (car BB) 3) (SETQ PT NIL))
((member (car BB) '(11 25)) (SETQ pt1 NIL) (EXIT))
((member BB '((2 97) (2 65)))
(COMMAND "ROTATE" SS "" PT1 90)
)
((member BB '((2 115) (2 83)))
(COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(1 0)) "Y")
)
((member BB '((2 100) (2 68)))
(COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(0 1)) "Y")
)
((member BB '((2 43) (2 61)))
(COMMAND "scale" SS "" PT1 "2")
)
((member BB '((2 116) (2 84)))
(setvar "osmode" oldos)
(redRaw)
(IF (setq pt (getpoint "\n请选择新基点"))
NIL
(exit)
)
(setvar "osmode" 0)
)
((equal BB '(2 45))
(COMMAND "scale" SS "" PT1 "0.5")
)
)
)
)
)
)
(Aerror_end)
)
;;;==================================================================
;;gxl-Sel-ReDrawSel 重画选择集中的对象，Sel 为选择集或图元名 mode 为方式码
;;;重画选择集中的对象，mode 为方式码，
;;;方式码 1 在屏幕重画该选择集对象
;;;方式码 2 隐藏该选择集对象
;;;方式码 3 “醒目显示”该选择集对象
;;;方式码 4 取消“醒目显示”该选择集对象--------BY G版
;;;==================================================================
(defun gxl-Sel-ReDrawSel (Sel mode / m n)
(if sel
(progn
(cond ((= 'pickset (type Sel))
(setq m (sslength Sel)
n 0
)
(repeat m
(redraw (ssname Sel n) mode)
(setq n (1+ n))
)
)
((= 'ename (type Sel))
(redraw Sel mode)
)
)
)
)
)
更新记录：
V1.1---增加多重复制， 修复空选,空点以及右键的正常退出。 【2013.6.20中午】
V1.2---增加橡皮筋、增加对齐选项、增加改转角选项。 【2013.6.21上午】
V1.3---增加输入距离选项、空格默认上次输入距离选项、修复光标变小问题。【2013.6.21下午】
V1.5---增加F3(或CTRL+F)开关对象捕捉，增加F8(或CTRL+L)开关正交。 【2013.6.22中午】
V1.6---修改输入距离为量取选项可根据屏幕两点确定距离，*JULI*全局变量.
如果输入的是数字则直接显示，与CAD复制一样。 【2013.6.23中午】
V1.8---彻底完善对象捕捉的支持，修复一点BUG，小小的优化了代码。 【终极版不再更新】
本人不再更新此程序，但喜欢此程序又有能力的以下几点供参考！
缺点及可完善项：
1、捕捉不到圆心，， ，，，，，，，，，，，，，，，，，，，，，，对此我毫无办法
2、没有对极轴模式的支持，，，，，，，，，，，，，，，，，，，，对此我深表遗憾
3、优化代码执行效率，用VLA函数代替command函数，，，，，，，，对此我充满期待
陈年老贴,楼主的自由复制自由移动都下载了，效果确实基本一样不知道你们使用效果如何，谈一下感受
运行命令是鼠标只要动，选择的物体就会闪动，一直持续
捕捉会变的比较迟钝
整体移动的时候也是非常非常非常（重要事情说三遍）卡卡卡，不知道哪段命令的原因
楼主也说了，就这么着，不更新很多年了，只是感觉这个代码权当娱乐还可以，真正能用到工作当中
好像根本不可能，就这个卡，都能把人憋死喽
我不知道大家使用的时候什么感觉，我的电脑反正运行命令是卡的一塌糊涂，实在没法用啊
下载，留着命令当个收藏吧，没事装装B!!!!仅此而已
以上感受只是自己使用的感受，实话实说而已，楼主莫怪，也希望可以出现个大神，能进一步优化一下
无比期待
希望，别改变光标，好像加这种函数纯属增加代码量，没有什么实际意义吧，直接默认多好
鼠标移动的时候希望能取消闪动可卡卡卡卡，就好！！
本帖最后由 小菜123 于 2014-7-14 10:25 编辑
试用了一下，因为自己使用习惯的原因，做了点修改，加了90度和45度的极轴追踪，为了简化，去掉几个键的功能，拷贝时可以使用快捷键定义的zoom w ;zoom p ;和一个自定义的view r o命令（没有考虑大小写的不同，只针对自己的定义命令），捕捉改为根据系统捕捉方式，发上源码供大家参考：(DEFUN C:c (/ SS PT SIZE OLDOSBB PT1 NEARPT
G2 H D LST PTXPTY PTT1 PTT2
PTT3 PTT4 AERROR Aerror_endolderr PT0 SS0
APT1 JULI zhuyi1 zhuyi2 F3F8 pt0x pt0y
STARTPT WS ASC REAL cl wpt1 wpt2 get_osmode
)
(defun Aerror(x)
(Aerror_end)
(AND oldos (COMMAND "ERASE" SS ""))
)
(defun Aerror_end ()
(setq *error* olderr)
(ifoldos
(setvar "osmode" oldos)
)
(ifoldCM
(setvar "cmdecho" oldCM)
)
(command "_.undo" "e")
(REDRAW)
(prinC)
)
;;;返回捕捉模式字串
(DEFUN get_osmode (/ cur_mode mode$)
(SETQ mode$ "")
(IF (< 0 (SETQ cur_mode (GETVAR "osmode")) 16384)
(MAPCAR (FUNCTION (LAMBDA (x)
(IF (NOT (ZEROP (LOGAND cur_mode (CAR x))))
(IF (ZEROP (STRLEN mode$))
(SETQ mode$ (CADR x))
(SETQ mode$ (STRCAT mode$ "," (CADR x)))
)
)
)
)
'((1 "_end")
(2 "_mid")
(4 "_cen")
(8 "_nod")
(16 "_qua")
(32 "_int")
(64 "_ins")
(128 "_per")
(256 "_tan")
(512 "_nea")
(1024 "_qui")
(2048 "_app")
(4096 "_ext")
(8192 "_par")
)
)
)
mode$
)
;;====================程序开始================
(IF (SETQ SS0 (SSGET ":L"))
(SETQ PT0 (getpoint "\n选择复制基点:"))
)
(IF (AND SS0 PT0)
(PROGN
(setq olderr*error*
*error* Aerror
)
(setq oldos (getvar "osmode")
oldCM (getvar "cmdecho")
)
(setq F8 (getvar "ORTHOMODE")
F3 T ws(vlax-Create-Object "WScript.Shell")
)
;;(setvar "osmode" 0)
(setvar "cmdecho" 0)
(setvar "nomutt" 0)
(setq zhuyi1 "\n点取位置或\n[转90度(A)/左右翻(D)/上下翻(S)/对齐(F)/改转角(G)/改基点(T)/默认<";;;/大1倍(+)/小一倍(-)/量取(Z)
zhuyi2 "mm>(空格)]"
)
(command "_.undo" "be")
(IF *JULI*
(setq juli *JULI*)
(setq juli 100)
)
(WHILE pt0
(if pt1
(setqpt pt1
pt0pt1
SS SS0
PT0X (mapcar '+ pt0 '(1 0 0))
PT0y (mapcar '+ pt0 '(0 1 0))
)
(setqpt pt0
SS SS0
PT0X (mapcar '+ pt0 '(1 0 0))
PT0y (mapcar '+ pt0 '(0 1 0))
)
)
(command "_.copy" SS "" "0,0" "@")
(PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
(while PT
(setqBB(grread T 5 1)
STARTPT(CADR BB)
)
(cond
((= (car BB) 5)
(SETQ PT1 STARTPT)
(redRaw)
(setq size (* (getvar "viewsize") 2))
(if (AND F3
(not (zerop (strlen (get_osmode)))) ;;有捕捉
(gxl-Sel-ReDrawSel SS 2)
(setq
nearpt (osnap PT1 (get_osmode)) ;;(osnap PT1 "_ENDP,_MID,_INT,NEA")
)
) ; 取得的捕捉点,端点，中点，交点,最近点.
(PROGN
(setq g2 nearpt)
(setq h (/ (getvar "viewsize")
(cadr (getvar "screensize"))
)
d (getvar "pickbox")
lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h))
ptx (car g2)
pty (cadr g2)
)
(foreach x lst
(setq ptt1 (list (- ptx x) (- pty x))
ptt2 (list (+ ptx x) (- pty x))
ptt3 (list (+ ptx x) (+ pty x))
ptt4 (list (- ptx x) (+ pty x))
)
(grvecs
(list 2 ptt1 ptt2 ptt2 ptt3 ptt3 ptt4 ptt4 ptt1)
)
)
(setq pt1 g2)
(gxl-Sel-ReDrawSel SS 1)
)
)
(IF (AND (= G2 NIL) (= F8 1))
(PROGN
(setq PT1 STARTPT)
(IF
(OR (< (* pi 0.25) (ANGLE PT1 PT0) (* pi 0.75))
(< (* pi 1.25) (ANGLE PT1 PT0) (* pi 1.75))
)
(SETQ PT1
(inters pt1
(polar pt1
(+ (angle pt0 pt0Y) (* pi 0.5))
1.0
)
pt0
pt0Y
nil
)
)
(SETQ PT1
(inters pt1
(polar pt1
(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
pt0X
nil
)
)
)
)
)
(cond ((AND (= G2 NIL)
(or (< (angle pt0 startpt) (* 0.01 pi)) (> (angle pt0 startpt) (* 1.99 pi)));;;0度方向
);;and
;;(PROGN;;(princ (angle pt0 startpt))
(SETQ PT1
(inters pt1
(polar pt1
(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
pt0X
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 0.26 pi)) (> (angle pt0 startpt) (* 0.24 pi)));;;45度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1 (* 0.75 pi)
;;(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
(polar pt0 (* 0.25 pi) 1.0)
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 0.51 pi)) (> (angle pt0 startpt) (* 0.49 pi)));;;90度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1
(+ (angle pt0 pt0Y) (* pi 0.5))
1.0
)
pt0
pt0Y
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 0.76 pi)) (> (angle pt0 startpt) (* 0.74 pi)));;;135度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1 (* 1.25 pi)
;;(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
(polar pt0 (* 0.75 pi) 1.0)
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 1.01 pi)) (> (angle pt0 startpt) (* 0.99 pi)));;;180度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1 (* 1.5 pi)
;;(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
(polar pt0 pi 1.0)
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 1.26 pi)) (> (angle pt0 startpt) (* 1.24 pi)));;;225度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1 (* 1.75 pi)
;;(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
(polar pt0 (* 1.25 pi) 1.0)
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 1.51 pi)) (> (angle pt0 startpt) (* 1.49 pi)));;;270度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1 (* 2 pi)
;;(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
(polar pt0 (* 1.5 pi) 1.0)
nil
)
) ;;setq
)
((AND (= G2 NIL)
(and (< (angle pt0 startpt) (* 1.76 pi)) (> (angle pt0 startpt) (* 1.74 pi)));;;270度方向
);;and
(SETQ PT1
(inters pt1
(polar pt1 (* 2.25 pi)
;;(+ (angle pt0 pt0X) (* pi 0.5))
1.0
)
pt0
(polar pt0 (* 1.75 pi) 1.0)
nil
)
) ;;setq
)
);;cond
(GRVECS
(LIST 1314
PT0
PT1
1314
STARTPT
(mapcar '+ (LIST size 0 0) STARTPT)
1314
STARTPT
(mapcar '- STARTPT (LIST size 0 0))
1314
STARTPT
(mapcar '- STARTPT (LIST 0 size 0))
1314
STARTPT
(mapcar '+ (LIST 0 size 0) STARTPT)
)
)
(COMMAND "MOVE" SS "" PT PT1)
(SETQ PT PT1
G2 NIL
)
)
((= (car BB) 3) (SETQ PT NIL))
((member (car BB) '(11 25)) (SETQ pt0 NIL) (EXIT))
((member BB '((2 97) (2 65)))
(COMMAND "ROTATE" SS "" PT1 90)
)
((member BB '((2 71) (2 103)));;((2 82) (2 114)) 大小写的R
(redraw)
(COMMAND "ROTATE" SS "" PT1 pause)
)
((member BB '((2 70) (2 102)))
(REDRAW)
;;对齐
(setvar "osmode" oldos)
(initget 1)
(IF (SETQ APT1 (getpoint "\n选择第一个源点:"))
(PROGN
(COMMAND "align" SS "" APT1)
(princ "\n选择第一个目标点:")
(COMMAND pause)
(princ "\n选择第二个源点:")
(COMMAND pause)
(princ "\n选择第二个目标点:")
(COMMAND pause)
(COMMAND "" "N")
(REDRAW)
(setvar "osmode" 0)
)
(PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
)
)
((member BB '((2 115) (2 83)))
(COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(1 0)) "Y")
)
;|
((member BB '((2 32)))
(IF JULI
(progn (setq pt1 (polar PT0 (ANGLE PT0 PT1) JULI))
(COMMAND "MOVE" SS "" PT PT1)
(SETQ PT nil)
)
)
)
|;
((and (null cl) (member BB '((2 32)))) (SETQ pt0 NIL) (EXIT)) ;;空格改为退出 cl是避免快捷键中的空格
((member BB
'((2 46)
(2 49)
(2 48)
(2 50)
(2 51)
(2 52)
(2 53)
(2 54)
(2 55)
(2 56)
(2 57)
)
)
(redraw)
(setq
ASC (CADR BB)
)
(setq real
(getreal
(car
(list ""
(vlax-invoke-method ws 'sendkeys (chr asc))
)
)
)
)
(setq pt1 (polar PT0 (ANGLE PT0 PT1) real))
(COMMAND "MOVE" SS "" pt PT1)
(SETQ *JULI* real
JULI*JULI*
PT NIL
)
)
;|
((member BB '((2 90) (2 122))) ;;;大小写的Z，与zoom冲突
(redraw)
(setq
juli (getdist
(strcat "\n输入复制距离<" (rtos juli 2) ">:")
)
)
(setq pt1 (polar PT0 (ANGLE PT0 PT1) JULI))
(COMMAND "MOVE" SS "" PT PT1)
(SETQ PT nil
*JULI* JULI
)
)
|;
((member BB '((2 100) (2 68)))
(COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(0 1)) "Y")
)
;;((member BB '((2 43) (2 61))) ;;+号
;; (COMMAND "scale" SS "" PT1 "2")
;; )
((member BB '((2 116) (2 84)))
(setvar "osmode" oldos)
(redRaw)
(IF (setq pt (getpoint "\n请选择新基点:"))
(PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
(exit)
)
(setvar "osmode" 0)
)
;; ((equal BB '(2 45)) ;-号
;;(COMMAND "scale" SS "" PT1 "0.5")
;; )
((equal BB '(2 6))
(if (= f3 NIL)
(progn (setq f3 T) (prompt "\n<对象捕捉 开>"))
(progn (setq f3 NIL) (prompt "\n<对象捕捉 关>"))
)
(redraw)
)
((equal BB '(2 15))
(if (= f8 0)
(progn (setq f8 1) (prompt "\n<正交 开>"))
(progn (setq f8 0) (prompt "\n<正交 关>"))
)
(setvar "orthomode" f8)
(redraw)
)
((member BB '((2 39)
(2 95)
(2 90)
(2 79)
(2 77)
(2 32)
(2 87)
(2 80)
(2 45)
(2 86)
(2 73)
(2 69)
(2 82)
(2 10)
)
);;member
(if (equal BB '(2 10))
(progn
(cond ((equal cl '(2 87))
(redraw)
(gxl-Sel-ReDrawSel SS 2)
(command "_.zoom" "w")
(initget 1)
(setq wpt1 (getpoint "\nSpecify first corner:"))
(initget 1)
(setq wpt2 (getcorner wpt1 "\nSpecify opposite corner:"))
;;(while (/= 0 (getvar "cmdactive")) (vl-cmdf PAUSE))
(command wpt1 wpt2)
(PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
)
((equal cl '(2 80)) (command "_.zoom" "p"))
((equal cl '(2 79)) (command "-view" "r" "o"))
)
(setq cl nil)
)
(setq cl bb);;else
)
)
)
)
;;END 内WHILE
)
;;END 外WHILE
) ;END progn
)
;;end if
(Aerror_end)
) 很好，可是 那个改转角无法输入？？ (PRINC "\n点取位置或 [转90度(A)/左右翻(D)/上下翻(S)/改转角()/改基点(T)]<退出>")
这句的改转角没有关键字哦 看不来不错，支持下 不错，继续完善 能不能实现多重复制呢？
能不能实现多重复制呢？楼上兄弟说得不错，活动了重复复制！还有不选择内容之后出现这个：
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。
未知命令“C”。按 F1 查看帮助。 先马克一下，坐等楼主的好程序 天正建筑中引线标注、标高、字体等字体要支持啊。哈哈 我记得楼主，本来是要告别lisp的。突然之间发了好多帖子呢！