77077 发表于 2020-9-4 11:07:05

连续复制,需要Express Tool支持

;连续复制,需要Express Tool支持

(defun c:cc (/ *error* redrawss ss0 p0 ss1 p1 v tmp)
(vl-load-com)
(defun redrawss (ss mode / m n)
    (setq m (sslength ss) n 0)
    (repeat m (redraw (ssname ss n) mode) (setq n (1+ n)))
)
(or *adoc* (setq *adoc* (vla-get-ActiveDocument (vlax-get-acad-object))))
(vla-endundomark *adoc*)
(vla-startundomark *adoc*)
(if (and (setq ss0 (ssget))(setq p0 (getpoint "\n指定基点:")))
    (progn
      (setq snap (getvar "osmode"))
      (command ".COPY" ss0 "" p0 p0)
      (setq ss1 ss0 v nil)
      (redrawss ss1 3)
      (while ss1
      (initget "R S D T E")
      (setq p1 (acet-ss-drag-move ss1 p0 (strcat "\n点取位置，或[转90度(R)/左右翻(S)/上下翻(D)/改基点(T)/退出(E)]<"(if v "重复上次" "退出")">:") 1 0))
      (if (and(not p1)v)(setq p1 (mapcar '+ p0 v)))
      (cond
          ((eq p1 "R")(command ".ROTATE" ss1 "" p0 "90") (redrawss ss1 3))
          ((eq p1 "S")(command ".MIRROR" ss1 "" p0 (list (car P0) (+ (cadr P0) (getvar 'viewsize))) "Y")(redrawss ss1 3))
          ((eq p1 "D")(command ".MIRROR" ss1 "" p0 (list (+ (car P0)(getvar 'viewsize))(cadr P0)) "Y") (redrawss ss1 3))
          ((eq p1 "T")(if(setq tmp (getpoint p0 " 指定新基点:")) (setq p0 tmp)) (redrawss ss1 3))
          ((eq p1 "E")(command ".ERASE" ss1 "")(setq ss1 nil)(setvar "osmode" snap))
          ((listp p1)
            (setvar "osmode" 0)
            (command ".move" ss1 "" p0 p1)
            (setq v (mapcar '- p1 p0) p0 p1 ss0 ss1)
            (command ".COPY" ss0 "" p0 p0)
            (setq ss1 ss0)
            (redrawss ss1 3)
            (setvar "osmode" snap)
          )
      )
      )
      (setvar "osmode" snap)
    )
)
(vla-endundomark *adoc*)
(princ)
)

ljfzx 发表于 2020-9-4 20:12:28

使用的时候 极轴无法生效

bai2000 发表于 2020-9-4 21:28:43

wowan1314 有个程序，地址自己找

;;;==================={ 自由复制V1.8 BY wowan1314 }================================;;;
;;; 功能：实现复制的过程中镜像、旋转、放大、缩小、对齐、改基点、改转角、记忆复制。         
;;; 特别鸣谢: G版 不死猫 xshrimp                                                   
;;; 特别说明：左键点取位置,右键退出,F3开关捕捉,F8开关正交,距离可直接输入无需按键         
;;; 量取Z的意思是：复制距离可由屏幕两点来确认，方便后面空格来默认距离                     
;;;===============================================================================;;;
;;;缺点：1、对于圆心的捕捉毫无办法。2、对极轴的支持。3、所有command都改为VLA函数。                               
;;;===============================================================================;;;

77077 发表于 2020-9-5 19:30:15

bai2000 发表于 2020-9-4 21:28
wowan1314 有个程序，地址自己找

;;;==================={ 自由复制V1.8 BY wowan1314 }=============== ...

你说的这个YY插件我用过，grread捕捉（捕捉最近点）有问题，会捕捉到动态移动的图元本身上去造成失误，所以我才自己写了这个。
郎大师也有个连续复制，不过对UCS支持不是很好（ucs下继续上一次复制会跑到不正确的地方去），且需要Esc退出。

77077 发表于 2020-9-5 19:37:10

ljfzx 发表于 2020-9-4 20:12
使用的时候 极轴无法生效

极轴坐标没问题呀。@5000<30
你输入的什么？

ljfzx 发表于 2020-9-6 10:23:53

指的是F10的极轴功能

Zrrrrr 发表于 2021-6-19 19:20:04

试了下，感觉很不错！但怎么能改为按Esc也能退出呢？

小毛草 发表于 2021-6-20 15:12:32

应该为ESC退出才行

Zrrrrr 发表于 2022-5-8 21:17:23

挺好用的。如果要改成Esc退出的话，可以如下操作：
1. 把 (if (and(not p1)v)(setq p1 (mapcar '+ p0 v))) 这一句改一下。
2. 把(command ".ERASE" ss1 "")(setq ss1 nil)(setvar "osmode" snap) 放到*error*函数里，但command 需改为command-s以便能在*error*里执行。

LENTSA 发表于 2022-10-4 15:04:16

挺好的，受教了！
页: [1]
查看完整版本: 连续复制,需要Express Tool支持