明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 54086|回复: 197

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

    [复制链接]
发表于 2013-6-20 16:25:24 | 显示全部楼层 |阅读模式
本帖最后由 wowan1314 于 2014-11-6 12:20 编辑

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

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

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

=========特别鸣谢G版=====================
  1. ;;;==================={ 自由复制V1.1 BY wowan1314 }================================
  2. ;;;功能:实现复制的过程中镜像、旋转、放大、缩小、修改复制基点。
  3. ;;;程序目标:在我的工作中取代CAD的复制命令
  4. ;;;                特别鸣谢 G版
  5. ;;;程序难点、复杂点均参考自G版的"带捕捉的GRREAD函数"-----
  6. ;;;程序的完善也将继续大抄特抄G版的代码,在此表示由衷的感谢。
  7. (DEFUN C:YY-COPY (/   SS  PT     SIZE   OLDOS  BB      PT1
  8.       NEARPT G2  H      D      LST    PTX    PTY
  9.       PTT1   PTT2  PTT3   PTT4   AERROR Aerror_end
  10.       olderr
  11.      )
  12.   (defun Aerror  (x)
  13.     (Aerror_end)
  14.     (AND olderr (COMMAND "ERASE" SS ""))
  15.   )
  16.   (defun Aerror_end ()
  17.     (if  oldos
  18.       (setvar "osmode" oldos)
  19.     )
  20.     (if  oldCM
  21.       (setvar "cmdecho" oldCM)
  22.     )
  23.     (command "_.undo" "e")
  24.     (REDRAW)
  25.     (prinC)
  26.   )
  27.   (IF (SETQ SS (SSGET ":L"))
  28.     (SETQ PT  (getpoint "\n选择复制基点:")
  29.     pt1 pt
  30.     )
  31.   )
  32.   (IF (AND SS PT)
  33.     (PROGN
  34.       (setq olderr  *error*
  35.       *error* Aerror
  36.       )
  37.       (setq size (* (getvar "viewsize") 2))
  38.       (setq oldos (getvar "osmode")
  39.       oldCM (getvar "cmdecho")
  40.       )
  41.       (setvar "osmode" 0)
  42.       (setvar "cmdecho" 0)
  43.       (command "_.undo" "be")
  44.       (WHILE pt1
  45.   (setq pt pt1)
  46.   (command "_.copy" SS "" "0,0" "@")
  47.   (PRINC
  48.     "\n点取位置或 [转90度(A)/左右翻(D)/上下翻(S)/改转角()/改基点(T)]<退出>"
  49.   )
  50.   (while PT
  51.     (setq BB (grread T 5 1))
  52.     (cond
  53.       ((= (car BB) 5)
  54.        (SETQ PT1 (CADR BB))
  55.        (redRaw)
  56.        (gxl-Sel-ReDrawSel SS 2)
  57.        (if
  58.          (setq
  59.      nearpt  (osnap PT1 "_ENDP,_MID,_INT,NEA")
  60.          )      ; 取得的捕捉点,端点,中点,交点
  61.     (PROGN
  62.       (setq g2 nearpt)
  63.       (setq  h   (/ (getvar "viewsize")
  64.              (cadr (getvar "screensize"))
  65.           )
  66.       d   (getvar "pickbox")
  67.       lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h))
  68.       ptx (car g2)
  69.       pty (cadr g2)
  70.       )
  71.       (foreach x lst
  72.         (setq ptt1 (list (- ptx x) (- pty x))
  73.         ptt2 (list (+ ptx x) (- pty x))
  74.         ptt3 (list (+ ptx x) (+ pty x))
  75.         ptt4 (list (- ptx x) (+ pty x))
  76.         )
  77.         (grvecs
  78.           (list 2 ptt1 ptt2 ptt2 ptt3 ptt3 ptt4 ptt4 ptt1)
  79.         )
  80.       )
  81.       (setq pt1 g2)
  82.     )
  83.        )
  84.        (GRVECS
  85.          (LIST 1314
  86.          PT1
  87.          (mapcar '+ (LIST size 0 0) PT1)
  88.          1314
  89.          PT1
  90.          (mapcar '- PT1 (LIST size 0 0))
  91.          1314
  92.          PT1
  93.          (mapcar '- PT1 (LIST 0 size 0))
  94.          1314
  95.          PT1
  96.          (mapcar '+ (LIST 0 size 0) PT1)
  97.          )
  98.        )
  99.        (gxl-Sel-ReDrawSel SS 1)
  100.        (COMMAND "MOVE" SS "" PT PT1)
  101.        (SETQ PT PT1)
  102.       )
  103.       ((= (car BB) 3) (SETQ PT NIL))
  104.       ((member (car BB) '(11 25)) (SETQ pt1 NIL) (EXIT))
  105.       ((member BB '((2 97) (2 65)))
  106.        (COMMAND "ROTATE" SS "" PT1 90)
  107.       )
  108.       ((member BB '((2 115) (2 83)))
  109.        (COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(1 0)) "Y")
  110.       )
  111.       ((member BB '((2 100) (2 68)))
  112.        (COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(0 1)) "Y")
  113.       )
  114.       ((member BB '((2 43) (2 61)))
  115.        (COMMAND "scale" SS "" PT1 "2")
  116.       )
  117.       ((member BB '((2 116) (2 84)))
  118.        (setvar "osmode" oldos)
  119.        (redRaw)
  120.        (IF (setq pt (getpoint "\n请选择新基点"))
  121.          NIL
  122.          (exit)
  123.        )
  124.        (setvar "osmode" 0)
  125.       )
  126.       ((equal BB '(2 45))
  127.        (COMMAND "scale" SS "" PT1 "0.5")
  128.       )
  129.     )
  130.   )
  131.       )
  132.     )
  133.   )
  134.   (Aerror_end)
  135. )
  136. ;;;==================================================================
  137. ;;gxl-Sel-ReDrawSel 重画选择集中的对象,Sel 为选择集或图元名 mode 为方式码
  138. ;;;重画选择集中的对象,mode 为方式码,
  139. ;;;方式码 1 在屏幕重画该选择集对象
  140. ;;;方式码 2 隐藏该选择集对象
  141. ;;;方式码 3 “醒目显示”该选择集对象
  142. ;;;方式码 4 取消“醒目显示”该选择集对象--------BY G版
  143. ;;;==================================================================
  144. (defun gxl-Sel-ReDrawSel (Sel mode / m n)
  145.   (if sel
  146.     (progn
  147.       (cond ((= 'pickset (type Sel))
  148.        (setq m (sslength Sel)
  149.        n 0
  150.        )
  151.        (repeat m
  152.          (redraw (ssname Sel n) mode)
  153.          (setq n (1+ n))
  154.        )
  155.       )
  156.       ((= 'ename (type Sel))
  157.        (redraw Sel mode)
  158.       )
  159.       )
  160.     )
  161.   )
  162. )


更新记录:
       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函数,,,,,,,,对此我充满期待




本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

点评

试了一下,我电脑上圆心可以捕捉到,VLA并不能提高效率,核心函数move ss并没有速度很快的VLA支持,对选择集内的单体实体采用VLA-MOVE效率太低。极轴追踪似不难实现,捕捉还可以增加支持键盘输入方式  发表于 2016-5-4 07:54
支持嚼黄瓜的,哈哈  发表于 2013-6-26 13:08
为提高效率,把command换成 vla函数吧!  发表于 2013-6-20 16:37

评分

参与人数 4明经币 +3 金钱 +10 收起 理由
ucuc2003 + 1 赞一个!
simpleye + 10
自贡黄明儒 + 1 很给力!
004 + 1 很给力!

查看全部评分

"觉得好,就打赏"
    共1人打赏

本帖被以下淘专辑推荐:

发表于 2020-1-13 16:35:11 | 显示全部楼层
陈年老贴,楼主的自由复制自由移动都下载了,效果确实基本一样不知道你们使用效果如何,谈一下感受
运行命令是鼠标只要动,选择的物体就会闪动,一直持续
捕捉会变的比较迟钝
整体移动的时候也是非常非常非常(重要事情说三遍)卡卡卡,不知道哪段命令的原因

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

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

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

使用道具 举报

发表于 2014-7-14 10:24:10 | 显示全部楼层
本帖最后由 小菜123 于 2014-7-14 10:25 编辑


试用了一下,因为自己使用习惯的原因,做了点修改,加了90度和45度的极轴追踪,为了简化,去掉几个键的功能,拷贝时可以使用快捷键定义的zoom w ;zoom p ;和一个自定义的view r o命令(没有考虑大小写的不同,只针对自己的定义命令),捕捉改为根据系统捕捉方式,发上源码供大家参考:
  1. (DEFUN C:c (/      SS     PT    SIZE   OLDOS  BB     PT1    NEARPT
  2.        G2      H     D    LST   PTX  PTY    PTT1   PTT2
  3.        PTT3   PTT4   AERROR Aerror_end  olderr PT0    SS0
  4.        APT1   JULI   zhuyi1 zhuyi2 F3  F8     pt0x   pt0y
  5.        STARTPT WS ASC REAL cl wpt1 wpt2 get_osmode
  6.       )
  7.   (defun Aerror  (x)
  8.     (Aerror_end)
  9.     (AND oldos (COMMAND "ERASE" SS ""))
  10.   )
  11.   (defun Aerror_end ()
  12.     (setq *error* olderr)
  13.     (if  oldos
  14.       (setvar "osmode" oldos)
  15.     )
  16.     (if  oldCM
  17.       (setvar "cmdecho" oldCM)
  18.     )
  19.     (command "_.undo" "e")
  20.     (REDRAW)
  21.     (prinC)
  22.   )
  23.   ;;;返回捕捉模式字串
  24.   (DEFUN get_osmode (/ cur_mode mode$)
  25.     (SETQ mode$ "")
  26.     (IF    (< 0 (SETQ cur_mode (GETVAR "osmode")) 16384)
  27.       (MAPCAR (FUNCTION    (LAMBDA    (x)
  28.               (IF (NOT (ZEROP (LOGAND cur_mode (CAR x))))
  29.                 (IF    (ZEROP (STRLEN mode$))
  30.                   (SETQ mode$ (CADR x))
  31.                   (SETQ mode$ (STRCAT mode$ "," (CADR x)))
  32.                 )
  33.               )
  34.             )
  35.           )
  36.           '((1 "_end")
  37.         (2 "_mid")
  38.         (4 "_cen")
  39.         (8 "_nod")
  40.         (16 "_qua")
  41.         (32 "_int")
  42.         (64 "_ins")
  43.         (128 "_per")
  44.         (256 "_tan")
  45.         (512 "_nea")
  46.         (1024 "_qui")
  47.         (2048 "_app")
  48.         (4096 "_ext")
  49.         (8192 "_par")
  50.            )
  51.       )
  52.     )
  53.     mode$
  54.   )
  55.     ;;====================程序开始================
  56.   (IF (SETQ SS0 (SSGET ":L"))
  57.     (SETQ PT0 (getpoint "\n选择复制基点:"))
  58.   )
  59.   (IF (AND SS0 PT0)
  60.     (PROGN
  61.       (setq olderr  *error*
  62.       *error* Aerror
  63.       )
  64.       (setq oldos (getvar "osmode")
  65.       oldCM (getvar "cmdecho")
  66.       )
  67.       (setq F8 (getvar "ORTHOMODE")
  68.       F3 T ws  (vlax-Create-Object "WScript.Shell")
  69.       )
  70.       ;;(setvar "osmode" 0)
  71.       (setvar "cmdecho" 0)
  72.       (setvar "nomutt" 0)
  73.       (setq zhuyi1 "\n点取位置或\n[转90度(A)/左右翻(D)/上下翻(S)/对齐(F)/改转角(G)/改基点(T)/默认<"  ;;;/大1倍(+)/小一倍(-)/量取(Z)
  74.       zhuyi2 "mm>(空格)]"
  75.       )
  76.       (command "_.undo" "be")
  77.       (IF *JULI*
  78.   (setq juli *JULI*)
  79.   (setq juli 100)
  80.       )
  81.       (WHILE pt0
  82.   (if pt1
  83.     (setq  pt   pt1
  84.     pt0  pt1
  85.     SS   SS0
  86.     PT0X (mapcar '+ pt0 '(1 0 0))
  87.     PT0y (mapcar '+ pt0 '(0 1 0))
  88.     )
  89.     (setq  pt   pt0
  90.     SS   SS0
  91.     PT0X (mapcar '+ pt0 '(1 0 0))
  92.     PT0y (mapcar '+ pt0 '(0 1 0))
  93.     )
  94.   )
  95.   (command "_.copy" SS "" "0,0" "@")
  96.   (PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
  97.   (while PT
  98.     (setq  BB  (grread T 5 1)
  99.     STARTPT  (CADR BB)
  100.     )
  101.     (cond
  102.       ((= (car BB) 5)
  103.        (SETQ PT1 STARTPT)
  104.        (redRaw)
  105.        (setq size (* (getvar "viewsize") 2))

  106.        (if (AND F3
  107.           (not (zerop (strlen (get_osmode)))) ;;有捕捉
  108.           (gxl-Sel-ReDrawSel SS 2)
  109.           (setq
  110.       nearpt (osnap PT1 (get_osmode)) ;;(osnap PT1 "_ENDP,_MID,_INT,NEA")
  111.           )
  112.      )      ; 取得的捕捉点,端点,中点,交点,最近点.
  113.          (PROGN
  114.      (setq g2 nearpt)
  115.      (setq h   (/ (getvar "viewsize")
  116.             (cadr (getvar "screensize"))
  117.          )
  118.            d   (getvar "pickbox")
  119.            lst (list (* d h) (* (- d 0.5) h) (* (+ d 0.5) h))
  120.            ptx (car g2)
  121.            pty (cadr g2)
  122.      )
  123.      (foreach x lst
  124.        (setq ptt1 (list (- ptx x) (- pty x))
  125.        ptt2 (list (+ ptx x) (- pty x))
  126.        ptt3 (list (+ ptx x) (+ pty x))
  127.        ptt4 (list (- ptx x) (+ pty x))
  128.        )
  129.        (grvecs
  130.          (list 2 ptt1 ptt2 ptt2 ptt3 ptt3 ptt4 ptt4 ptt1)
  131.        )
  132.      )
  133.      (setq pt1 g2)
  134.      (gxl-Sel-ReDrawSel SS 1)
  135.          )
  136.        )
  137.        (IF (AND (= G2 NIL) (= F8 1))
  138.          (PROGN
  139.      (setq PT1 STARTPT)
  140.      (IF
  141.        (OR (< (* pi 0.25) (ANGLE PT1 PT0) (* pi 0.75))
  142.            (< (* pi 1.25) (ANGLE PT1 PT0) (* pi 1.75))
  143.        )
  144.         (SETQ PT1
  145.          (inters pt1
  146.            (polar pt1
  147.             (+ (angle pt0 pt0Y) (* pi 0.5))
  148.             1.0
  149.            )
  150.            pt0
  151.            pt0Y
  152.            nil
  153.          )
  154.         )
  155.         (SETQ PT1
  156.          (inters pt1
  157.            (polar pt1
  158.             (+ (angle pt0 pt0X) (* pi 0.5))
  159.             1.0
  160.            )
  161.            pt0
  162.            pt0X
  163.            nil
  164.          )
  165.         )
  166.      )
  167.          )
  168.        )
  169.        (cond ((AND (= G2 NIL)
  170.              (or (< (angle pt0 startpt) (* 0.01 pi)) (> (angle pt0 startpt) (* 1.99 pi)))  ;;;0度方向
  171.          );;and
  172.                        ;;(PROGN  ;;(princ (angle pt0 startpt))
  173.          (SETQ PT1
  174.          (inters pt1
  175.            (polar pt1
  176.             (+ (angle pt0 pt0X) (* pi 0.5))
  177.             1.0
  178.            )
  179.            pt0
  180.            pt0X
  181.            nil
  182.          )
  183.          ) ;;setq
  184.              )
  185.        ((AND (= G2 NIL)
  186.              (and (< (angle pt0 startpt) (* 0.26 pi)) (> (angle pt0 startpt) (* 0.24 pi)))  ;;;45度方向
  187.          );;and
  188.          (SETQ PT1
  189.          (inters pt1
  190.            (polar pt1 (* 0.75 pi)
  191.             ;;(+ (angle pt0 pt0X) (* pi 0.5))
  192.             1.0
  193.            )
  194.            pt0
  195.            (polar pt0 (* 0.25 pi) 1.0)
  196.            nil
  197.          )
  198.          ) ;;setq
  199.              )
  200.        ((AND (= G2 NIL)
  201.              (and (< (angle pt0 startpt) (* 0.51 pi)) (> (angle pt0 startpt) (* 0.49 pi)))  ;;;90度方向
  202.          );;and
  203.          (SETQ PT1
  204.          (inters pt1
  205.            (polar pt1
  206.             (+ (angle pt0 pt0Y) (* pi 0.5))
  207.             1.0
  208.            )
  209.            pt0
  210.            pt0Y
  211.            nil
  212.          )
  213.         ) ;;setq
  214.              )
  215.        ((AND (= G2 NIL)
  216.              (and (< (angle pt0 startpt) (* 0.76 pi)) (> (angle pt0 startpt) (* 0.74 pi)))  ;;;135度方向
  217.          );;and
  218.          (SETQ PT1
  219.          (inters pt1
  220.            (polar pt1 (* 1.25 pi)
  221.               ;;(+ (angle pt0 pt0X) (* pi 0.5))
  222.             1.0
  223.            )
  224.            pt0
  225.            (polar pt0 (* 0.75 pi) 1.0)
  226.            nil
  227.          )
  228.          ) ;;setq
  229.              )
  230.        ((AND (= G2 NIL)
  231.              (and (< (angle pt0 startpt) (* 1.01 pi)) (> (angle pt0 startpt) (* 0.99 pi)))  ;;;180度方向
  232.          );;and
  233.          (SETQ PT1
  234.          (inters pt1
  235.            (polar pt1 (* 1.5 pi)
  236.               ;;(+ (angle pt0 pt0X) (* pi 0.5))
  237.             1.0
  238.            )
  239.            pt0
  240.            (polar pt0 pi 1.0)
  241.            nil
  242.          )
  243.          ) ;;setq
  244.              )
  245.        ((AND (= G2 NIL)
  246.              (and (< (angle pt0 startpt) (* 1.26 pi)) (> (angle pt0 startpt) (* 1.24 pi)))  ;;;225度方向
  247.          );;and
  248.          (SETQ PT1
  249.          (inters pt1
  250.            (polar pt1 (* 1.75 pi)
  251.               ;;(+ (angle pt0 pt0X) (* pi 0.5))
  252.             1.0
  253.            )
  254.            pt0
  255.            (polar pt0 (* 1.25 pi) 1.0)
  256.            nil
  257.          )
  258.          ) ;;setq
  259.              )
  260.        ((AND (= G2 NIL)
  261.              (and (< (angle pt0 startpt) (* 1.51 pi)) (> (angle pt0 startpt) (* 1.49 pi)))  ;;;270度方向
  262.          );;and
  263.          (SETQ PT1
  264.          (inters pt1
  265.            (polar pt1 (* 2 pi)
  266.               ;;(+ (angle pt0 pt0X) (* pi 0.5))
  267.             1.0
  268.            )
  269.            pt0
  270.            (polar pt0 (* 1.5 pi) 1.0)
  271.            nil
  272.          )
  273.          ) ;;setq
  274.              )
  275.        ((AND (= G2 NIL)
  276.              (and (< (angle pt0 startpt) (* 1.76 pi)) (> (angle pt0 startpt) (* 1.74 pi)))  ;;;270度方向
  277.          );;and
  278.          (SETQ PT1
  279.          (inters pt1
  280.            (polar pt1 (* 2.25 pi)
  281.               ;;(+ (angle pt0 pt0X) (* pi 0.5))
  282.             1.0
  283.            )
  284.            pt0
  285.            (polar pt0 (* 1.75 pi) 1.0)
  286.            nil
  287.          )
  288.          ) ;;setq
  289.              )
  290.        );;cond
  291.        (GRVECS
  292.          (LIST 1314
  293.          PT0
  294.          PT1
  295.          1314
  296.          STARTPT
  297.          (mapcar '+ (LIST size 0 0) STARTPT)
  298.          1314
  299.          STARTPT
  300.          (mapcar '- STARTPT (LIST size 0 0))
  301.          1314
  302.          STARTPT
  303.          (mapcar '- STARTPT (LIST 0 size 0))
  304.          1314
  305.          STARTPT
  306.          (mapcar '+ (LIST 0 size 0) STARTPT)
  307.          )
  308.        )
  309.        (COMMAND "MOVE" SS "" PT PT1)
  310.        (SETQ PT PT1
  311.        G2 NIL
  312.        )
  313.       )
  314.       ((= (car BB) 3) (SETQ PT NIL))
  315.       ((member (car BB) '(11 25)) (SETQ pt0 NIL) (EXIT))
  316.       ((member BB '((2 97) (2 65)))
  317.        (COMMAND "ROTATE" SS "" PT1 90)
  318.       )
  319.       ((member BB '((2 71) (2 103)))  ;;((2 82) (2 114)) 大小写的R
  320.        (redraw)
  321.        (COMMAND "ROTATE" SS "" PT1 pause)
  322.       )
  323.       ((member BB '((2 70) (2 102)))
  324.        (REDRAW)
  325.        ;;对齐
  326.        (setvar "osmode" oldos)
  327.        (initget 1)
  328.        (IF (SETQ APT1 (getpoint "\n选择第一个源点:"))
  329.          (PROGN
  330.      (COMMAND "align" SS "" APT1)
  331.      (princ "\n选择第一个目标点:")
  332.      (COMMAND pause)
  333.      (princ "\n选择第二个源点:")
  334.      (COMMAND pause)
  335.      (princ "\n选择第二个目标点:")
  336.      (COMMAND pause)
  337.      (COMMAND "" "N")
  338.      (REDRAW)
  339.      (setvar "osmode" 0)
  340.          )
  341.          (PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
  342.        )
  343.       )
  344.       ((member BB '((2 115) (2 83)))
  345.        (COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(1 0)) "Y")
  346.       )
  347.            ;|
  348.       ((member BB '((2 32)))
  349.        (IF JULI
  350.          (progn (setq pt1 (polar PT0 (ANGLE PT0 PT1) JULI))
  351.           (COMMAND "MOVE" SS "" PT PT1)
  352.           (SETQ PT nil)
  353.          )
  354.        )
  355.       )
  356.       |;
  357.       ((and (null cl) (member BB '((2 32)))) (SETQ pt0 NIL) (EXIT)) ;;空格改为退出 cl是避免快捷键中的空格
  358.       ((member BB
  359.          '((2 46)
  360.            (2 49)
  361.            (2 48)
  362.            (2 50)
  363.            (2 51)
  364.            (2 52)
  365.            (2 53)
  366.            (2 54)
  367.            (2 55)
  368.            (2 56)
  369.            (2 57)
  370.           )
  371.        )
  372.        (redraw)
  373.        (setq
  374.        ASC (CADR BB)
  375.        )
  376.        (setq real
  377.         (getreal
  378.           (car
  379.       (list ""
  380.             (vlax-invoke-method ws 'sendkeys (chr asc))
  381.       )
  382.           )
  383.         )
  384.        )
  385.        (setq pt1 (polar PT0 (ANGLE PT0 PT1) real))
  386.        (COMMAND "MOVE" SS "" pt PT1)
  387.        (SETQ *JULI* real
  388.        JULI  *JULI*
  389.        PT NIL
  390.        )
  391.       )
  392.       ;|
  393.       ((member BB '((2 90) (2 122))) ;;;大小写的Z,与zoom冲突
  394.        (redraw)
  395.        (setq
  396.          juli (getdist
  397.           (strcat "\n输入复制距离<" (rtos juli 2) ">:")
  398.         )
  399.        )
  400.        (setq pt1 (polar PT0 (ANGLE PT0 PT1) JULI))
  401.        (COMMAND "MOVE" SS "" PT PT1)
  402.        (SETQ PT nil
  403.        *JULI* JULI
  404.        )
  405.       )
  406.       |;
  407.       ((member BB '((2 100) (2 68)))
  408.        (COMMAND "mirror" SS "" PT1 (mapcar '- pt1 '(0 1)) "Y")
  409.       )
  410.       ;;((member BB '((2 43) (2 61))) ;;+号
  411.       ;; (COMMAND "scale" SS "" PT1 "2")
  412.      ;; )
  413.       ((member BB '((2 116) (2 84)))
  414.        (setvar "osmode" oldos)
  415.        (redRaw)
  416.        (IF (setq pt (getpoint "\n请选择新基点:"))
  417.          (PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
  418.          (exit)
  419.        )
  420.        (setvar "osmode" 0)
  421.       )
  422.      ;; ((equal BB '(2 45)) ;-号
  423.      ;;  (COMMAND "scale" SS "" PT1 "0.5")
  424.      ;; )
  425.       ((equal BB '(2 6))
  426.        (if (= f3 NIL)
  427.          (progn (setq f3 T) (prompt "\n<对象捕捉 开>"))
  428.          (progn (setq f3 NIL) (prompt "\n<对象捕捉 关>"))
  429.        )
  430.        (redraw)
  431.       )
  432.       ((equal BB '(2 15))
  433.        (if (= f8 0)
  434.          (progn (setq f8 1) (prompt "\n<正交 开>"))
  435.          (progn (setq f8 0) (prompt "\n<正交 关>"))
  436.        )
  437.        (setvar "orthomode" f8)
  438.        (redraw)
  439.       )
  440.       ((member BB '((2 39)
  441.         (2 95)
  442.         (2 90)
  443.         (2 79)
  444.         (2 77)
  445.         (2 32)
  446.         (2 87)
  447.         (2 80)
  448.         (2 45)
  449.         (2 86)
  450.         (2 73)
  451.         (2 69)
  452.         (2 82)
  453.         (2 10)
  454.        )
  455.         );;member
  456.        (if (equal BB '(2 10))
  457.            (progn  
  458.        (cond ((equal cl '(2 87))
  459.         (redraw)
  460.         (gxl-Sel-ReDrawSel SS 2)
  461.         (command "_.zoom" "w")
  462.         (initget 1)
  463.         (setq wpt1 (getpoint "\nSpecify first corner:"))
  464.         (initget 1)
  465.         (setq wpt2 (getcorner wpt1 "\nSpecify opposite corner:"))
  466.         ;;(while (/= 0 (getvar "cmdactive")) (vl-cmdf PAUSE))
  467.         (command wpt1 wpt2)
  468.         (PRINC (strcat zhuyi1 (rtos juli 2) zhuyi2))
  469.        )
  470.        ((equal cl '(2 80)) (command "_.zoom" "p"))
  471.        ((equal cl '(2 79)) (command "-view" "r" "o"))
  472.                    )
  473.        (setq cl nil)
  474.      )
  475.            (setq cl bb);;else
  476.        )   
  477.            
  478.       )
  479.     )
  480.   )
  481.   ;;END 内WHILE

  482.       )
  483.       ;;END 外WHILE
  484.     )          ;END progn
  485.   )
  486.   ;;end if
  487.   (Aerror_end)
  488. )

评分

参与人数 2明经币 +1 金钱 +6 收起 理由
baoyizhu + 6 很给力!
wowan1314 + 1 赞一个! 圆心如何捕捉到的呢?

查看全部评分

回复 支持 1 反对 0

使用道具 举报

发表于 2013-6-20 16:43:20 | 显示全部楼层
很好,可是 那个改转角无法输入??

点评

改转角还没加呢! 有时间来一一完善!  发表于 2013-6-20 16:49
发表于 2013-6-20 16:46:14 | 显示全部楼层
(PRINC "\n点取位置或 [转90度(A)/左右翻(D)/上下翻(S)/改转角()/改基点(T)]<退出>")
这句的改转角没有关键字哦

点评

改转角还没加呢! 有时间来一一完善!可能更新的比较慢。  发表于 2013-6-20 16:49
发表于 2013-6-20 16:52:57 | 显示全部楼层
看不来不错,支持下
发表于 2013-6-20 16:53:30 | 显示全部楼层
不错,继续完善
发表于 2013-6-20 17:03:14 | 显示全部楼层
能不能实现多重复制呢?

点评

已更新!  发表于 2013-6-20 17:46
发表于 2013-6-20 17:09:06 | 显示全部楼层

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

点评

已修复  发表于 2013-6-20 17:46
发表于 2013-6-20 17:29:45 | 显示全部楼层
先马克一下,坐等楼主的好程序

点评

坐等估计有困难! 累了就躺会。。  发表于 2013-6-20 17:50
发表于 2013-6-20 18:18:13 | 显示全部楼层
天正建筑中引线标注、标高、字体等字体要支持啊。哈哈

点评

你如果用天正就没必要用这个程序啦。 这个也只是仿天正而已。  发表于 2013-6-20 18:39
发表于 2013-6-20 19:55:40 | 显示全部楼层
我记得楼主,本来是要告别lisp的。突然之间发了好多帖子呢!

点评

马上就要告别了! 离别是为了再见。 呵呵 。  发表于 2013-6-22 17:47
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-12-23 20:30 , Processed in 0.227359 second(s), 35 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表