【源码分享之自由系列1】可代替copy的自由复制程序--------V1.8版

wowan1314 · 发表于 2013-6-20 16:25

本帖最后由 wowan1314 于 2014-11-6 12:20 编辑

程序实现COPY过程中动态的进行镜像、旋转、放大、缩小、对齐、改基点、改转角及记忆复制。

程序现在已基本成型。以后不会更新了！

如果有朋友完善或扩展了此程序。也请发至论坛,以便大家学习，敬谢！！

=========特别鸣谢G版=====================

;;;==================={ 自由复制V1.1 BY wowan1314 }================================
;;;功能：实现复制的过程中镜像、旋转、放大、缩小、修改复制基点。
;;;程序目标：在我的工作中取代CAD的复制命令
;;; 特别鸣谢 G版
;;;程序难点、复杂点均参考自G版的"带捕捉的GRREAD函数"-----
;;;程序的完善也将继续大抄特抄G版的代码，在此表示由衷的感谢。
(DEFUN C:YY-COPY (/ SS PT SIZE OLDOS BB PT1
NEARPT G2 H D LST PTX PTY
PTT1 PTT2 PTT3 PTT4 AERROR Aerror_end
olderr
)
(defun Aerror (x)
(Aerror_end)
(AND olderr (COMMAND "ERASE" SS ""))
)
(defun Aerror_end ()
(if oldos
(setvar "osmode" oldos)
)
(if oldCM
(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)
(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)
)
)
(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 BY wowan1314 }================================ 
;;;功能：实现复制的过程中镜像、旋转、放大、缩小、修改复制基点。 
;;;程序目标：在我的工作中取代CAD的复制命令 
;;;                特别鸣谢 G版 
;;;程序难点、复杂点均参考自G版的"带捕捉的GRREAD函数"----- 
;;;程序的完善也将继续大抄特抄G版的代码，在此表示由衷的感谢。 
(DEFUN C:YY-COPY (/   SS  PT     SIZE   OLDOS  BB      PT1 
      NEARPT G2  H      D      LST    PTX    PTY 
      PTT1   PTT2  PTT3   PTT4   AERROR Aerror_end 
      olderr 
     ) 
  (defun Aerror  (x) 
    (Aerror_end) 
    (AND olderr (COMMAND "ERASE" SS "")) 
  ) 
  (defun Aerror_end () 
    (if  oldos 
      (setvar "osmode" oldos) 
    ) 
    (if  oldCM 
      (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) 
      (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) 
    ) 
       ) 
       (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函数，，，，，，，，对此我充满期待

xj6019 · 发表于 2020-1-13 16:35

陈年老贴,楼主的自由复制自由移动都下载了，效果确实基本一样不知道你们使用效果如何，谈一下感受
运行命令是鼠标只要动，选择的物体就会闪动，一直持续
捕捉会变的比较迟钝
整体移动的时候也是非常非常非常（重要事情说三遍）卡卡卡，不知道哪段命令的原因

楼主也说了，就这么着，不更新很多年了，只是感觉这个代码权当娱乐还可以，真正能用到工作当中
好像根本不可能，就这个卡，都能把人憋死喽

我不知道大家使用的时候什么感觉，我的电脑反正运行命令是卡的一塌糊涂，实在没法用啊
下载，留着命令当个收藏吧，没事装装B!!!!仅此而已

以上感受只是自己使用的感受，实话实说而已，楼主莫怪，也希望可以出现个大神，能进一步优化一下
无比期待
希望，别改变光标，好像加这种函数纯属增加代码量，没有什么实际意义吧，直接默认多好
鼠标移动的时候希望能取消闪动可卡卡卡卡，就好！！

小菜123 · 发表于 2014-7-14 10:24

本帖最后由小菜123 于 2014-7-14 10:25 编辑

试用了一下，因为自己使用习惯的原因，做了点修改，加了90度和45度的极轴追踪，为了简化，去掉几个键的功能，拷贝时可以使用快捷键定义的zoom w ;zoom p ;和一个自定义的view r o命令（没有考虑大小写的不同，只针对自己的定义命令），捕捉改为根据系统捕捉方式，发上源码供大家参考：

(DEFUN C:c (/ SS PT SIZE OLDOS BB PT1 NEARPT
G2 H D LST PTX PTY PTT1 PTT2
PTT3 PTT4 AERROR Aerror_end olderr PT0 SS0
APT1 JULI zhuyi1 zhuyi2 F3 F8 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)
(if oldos
(setvar "osmode" oldos)
)
(if oldCM
(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
(setq pt pt1
pt0 pt1
SS SS0
PT0X (mapcar '+ pt0 '(1 0 0))
PT0y (mapcar '+ pt0 '(0 1 0))
)
(setq pt 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
(setq BB (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)
)

(DEFUN C:c (/      SS     PT    SIZE   OLDOS  BB     PT1    NEARPT 
       G2      H     D    LST   PTX  PTY    PTT1   PTT2 
       PTT3   PTT4   AERROR Aerror_end  olderr PT0    SS0 
       APT1   JULI   zhuyi1 zhuyi2 F3  F8     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) 
    (if  oldos 
      (setvar "osmode" oldos) 
    ) 
    (if  oldCM 
      (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 
    (setq  pt   pt1 
    pt0  pt1 
    SS   SS0 
    PT0X (mapcar '+ pt0 '(1 0 0)) 
    PT0y (mapcar '+ pt0 '(0 1 0)) 
    ) 
    (setq  pt   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 
    (setq  BB  (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) 
)

ly8zx2109 · 发表于 2013-6-20 16:43

很好，可是那个改转角无法输入？？

vvcd · 发表于 2013-6-20 16:46

(PRINC "\n点取位置或 [转90度(A)/左右翻(D)/上下翻(S)/改转角()/改基点(T)]<退出>")
这句的改转角没有关键字哦

hehaidizhi · 发表于 2013-6-20 16:52

看不来不错，支持下

wangph · 发表于 2013-6-20 16:53

不错，继续完善

vvcd · 发表于 2013-6-20 17:03

能不能实现多重复制呢？

小毛草 · 发表于 2013-6-20 17:09

能不能实现多重复制呢？楼上兄弟说得不错，活动了重复复制！还有不选择内容之后出现这个：
未知命令“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 查看帮助。

dongya1235 · 发表于 2013-6-20 17:29

先马克一下，坐等楼主的好程序

bai2000 · 发表于 2013-6-20 18:18

天正建筑中引线标注、标高、字体等字体要支持啊。哈哈

vlisp2012 · 发表于 2013-6-20 19:55

我记得楼主，本来是要告别lisp的。突然之间发了好多帖子呢！

账号		自动登录	找回密码
密码			注册

[源码] 【源码分享之自由系列1】可代替copy的自由复制程序--------V1.8版

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

评分

点评

点评

点评

点评

点评

点评

点评