设为首页收藏本站

晓东CAD家园-论坛

 找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 9975|回复: 44

[每日一码] 【源码分享之自由系列2】可代替CTRL+V的“自由粘贴”程序----V1.0

[复制链接]
发表于 2013-6-24 13:51:17 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

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

x
   程序实现CTRL+V过程中动态的进行镜像、旋转、放大、缩小、对齐、改基点、改转角及记忆粘贴。
                                                                “自由粘贴”为“自由复制”的姊妹篇


程序现在已基本成型。 先将程序分享出来。希望对你有用(本人使用天正的,哈哈)

希望有兴趣的朋友自己来完善此程序,本人水平精力有限。(如您完善了此程序,记得发表哦 ,以便供我学习)
自由粘贴.gif

[sell];;;==================={ 自由粘贴V1.0 BY wowan1314 }================================;;;
;;;功能:实现粘贴的过程中镜像、旋转、放大、缩小、对齐、改基点、改转角、记忆复制。  ;;;
;;;                特别鸣谢: G版 不死猫 xshrimp                                    ;;;
;;;特别说明:左键点取位置,右键退出,F3开关捕捉,F8开关正交,距离可直接输入无需按键    ;;;
;;;          量取Z的意思是:复制距离可由屏幕两点来确认,方便后面空格来默认距离     ;;;
;;;================================================================================;;;
(DEFUN C:YY-CTRLV (/                      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  SS
            )
  (defun Aerror        (x)
    (Aerror_end)
    (vl-cmdf "_.ERASE" SS "")
    (prinC X)
  )
  (defun Aerror_end ()
    (setq *error* olderr)
    (if        oldos
      (setvar "osmode" oldos)
    )
    (if        oldCM
      (setvar "cmdecho" oldCM)
    )
    (command "_.undo" "e")
    (REDRAW)
  )

      (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)/改转角(R)/改基点(T)/大1倍(+)/小一倍(-)/量取(Z)/默认<"
            zhuyi2 "mm>(空格)]<退出>"
      )
      (command "_.undo" "be")
      (IF *JULI2*
        (setq juli *JULI2*)
        (setq juli 100)
      )
        (SETQ ENT (ENTLAST) PT0 '(0 0 0))
        (VL-CMDF "_pasteclip" PT0)
      (SETQ SS (last_ent ENT))
      (WHILE pt0
        (if pt1
          (setq        pt   pt1
                pt0  pt1
                PT0X (mapcar '+ pt0 '(1 0 0))
                PT0y (mapcar '+ pt0 '(0 1 0))
          )
          (setq        pt   pt0
                PT0X (mapcar '+ pt0 '(1 0 0))
                PT0y (mapcar '+ pt0 '(0 1 0))
          )
        )
         (IF PT1 (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
                      (gxl-Sel-ReDrawSel SS 2)
                      (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)
                 (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
                           )
                    )
                 )
               )
             )
             (GRVECS
               (LIST
                     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)
               )
             )
             (VL-CMDF "MOVE" SS "" PT PT1)
             (SETQ PT PT1
                   G2 NIL
             )
            )
            ((= (car BB) 3) (SETQ PT NIL))
            ((member (car BB) '(11 25)) (SETQ pt0 NIL) (COMMAND "_.ERASE" SS "") (EXIT))
            ((member BB '((2 97) (2 65)))
             (COMMAND "ROTATE" SS "" PT1 90)
            )
            ((member BB '((2 82) (2 114)))
             (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)
               )
             )
            )
            ((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 *JULI2* real
                   JULI        *JULI2*
                   PT NIL
             )
            )
            ((member BB '((2 90) (2 122)))
             (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
                   *JULI2* 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)
            )
          )
        )
        ;;END 内WHILE

      )
      ;;END 外WHILE
       
  (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)
            )
      )
    )
  )
  T
)
;;;======================函数取得EN之后生成的所有图元的选择集
(defun last_ent (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
       );while
       (if (zerop (sslength ss)) (setq ss nil))
       ss
     );progn
     (ssget "_x")
   );if
)[/sell]

评分

参与人数 5威望 +1 D豆 +35 贡献 +2 收起 理由
xshrimp + 5 很给力!经验;技术要点;资料分享奖!
liuchong1988 + 10 很给力!经验;技术要点;资料分享奖!
XDSoft + 1 + 10 很给力!经验;技术要点;资料分享奖!
炫翔 + 5 + 1 很给力!经验;技术要点;资料分享奖!
牢固 + 5 + 1 很给力!经验;技术要点;资料分享奖!

查看全部评分

本帖被以下淘专辑推荐:

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
 楼主| 发表于 2013-6-24 14:02:23 | 显示全部楼层
    特别鸣谢: G版 不死猫 xshrimp

在制作过程中遇到几个难点,均是从他们的帖子中学到的解决办法。 感谢   
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1260个

财富等级: 财源广进

发表于 2013-6-24 14:11:50 | 显示全部楼层
站个座,支持一下
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 2476个

财富等级: 金玉满堂

发表于 2013-6-25 10:54:07 | 显示全部楼层
老大,自由复制和自由粘贴的区别在哪??
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-25 12:40:43 | 显示全部楼层
就是捕捉不是很好用!如果能像CAD本身的捕捉那就非常强大了!天正的捕捉跟CAD的一样!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 1967个

财富等级: 堆金积玉

发表于 2013-6-25 14:09:16 | 显示全部楼层
nice program
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-26 02:17:15 | 显示全部楼层
很好的程序,非常实用,就是捕捉不给力!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-6-26 03:15:53 | 显示全部楼层
貌似好强大!!!!!!!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-7-4 19:36:35 | 显示全部楼层
顶楼主,不错的工具,确实带来很多方便!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-11-18 13:38:20 | 显示全部楼层
谢谢楼主的程序
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 34个

财富等级: 招财进宝

发表于 2013-12-5 12:48:49 | 显示全部楼层
支持下,还是不错的
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2013-12-7 11:43:58 | 显示全部楼层
看看 学习学习下
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

已领礼包: 41个

财富等级: 招财进宝

发表于 2014-1-17 16:27:44 | 显示全部楼层
老大,自由复制和自由粘贴的区别在哪
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2014-3-14 22:37:03 | 显示全部楼层
试了一下,老是设置我的文字样式!
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

发表于 2014-3-15 17:23:00 | 显示全部楼层
谢谢分享啊:)
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|小黑屋|手机版|Archiver|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )  

GMT+8, 2021-1-16 08:07 , Processed in 0.203261 second(s), 50 queries , Gzip On, WinCache On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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