连续复制,需要Express Tool支持

77077

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

1. (defun c:cc (/ *error* redrawss ss0 p0 ss1 p1 v tmp)
   
2.   (vl-load-com)
   
3.   (defun redrawss (ss mode / m n)
   
4.     (setq m (sslength ss) n 0)
   
5.     (repeat m (redraw (ssname ss n) mode) (setq n (1+ n)))
   
6.   )
   
7.   (or *adoc* (setq *adoc* (vla-get-ActiveDocument (vlax-get-acad-object))))
   
8.   (vla-endundomark *adoc*)
   
9.   (vla-startundomark *adoc*)
   
10.   (if (and (setq ss0 (ssget))(setq p0 (getpoint "\n指定基点:")))
    
11.     (progn
    
12.       (setq snap (getvar "osmode"))
    
13.       (command ".COPY" ss0 "" p0 p0)
    
14.       (setq ss1 ss0 v nil)
    
15.       (redrawss ss1 3)
    
16.       (while ss1
    
17.         (initget "R S D T E")
    
18.         (setq p1 (acet-ss-drag-move ss1 p0 (strcat "\n点取位置，或[转90度(R)/左右翻(S)/上下翻(D)/改基点(T)/退出(E)]<"(if v "重复上次" "退出")">:") 1 0))
    
19.         (if (and(not p1)v)(setq p1 (mapcar '+ p0 v)))
    
20.         (cond
    
21.           ((eq p1 "R")(command ".ROTATE" ss1 "" p0 "90") (redrawss ss1 3))
    
22.           ((eq p1 "S")(command ".MIRROR" ss1 "" p0 (list (car P0) (+ (cadr P0) (getvar 'viewsize))) "Y")(redrawss ss1 3))
    
23.           ((eq p1 "D")(command ".MIRROR" ss1 "" p0 (list (+ (car P0)(getvar 'viewsize))(cadr P0)) "Y") (redrawss ss1 3))
    
24.           ((eq p1 "T")(if(setq tmp (getpoint p0 " 指定新基点:")) (setq p0 tmp)) (redrawss ss1 3))
    
25.           ((eq p1 "E")(command ".ERASE" ss1 "")(setq ss1 nil)(setvar "osmode" snap))
    
26.           ((listp p1)
    
27.             (setvar "osmode" 0)
    
28.             (command ".move" ss1 "" p0 p1)
    
29.             (setq v (mapcar '- p1 p0) p0 p1 ss0 ss1)
    
30.             (command ".COPY" ss0 "" p0 p0)
    
31.             (setq ss1 ss0)
    
32.             (redrawss ss1 3)
    
33.             (setvar "osmode" snap)
    
34.           )
    
35.         )
    
36.       )
    
37.       (setvar "osmode" snap)
    
38.     )
    
39.   )
    
40.   (vla-endundomark *adoc*)
    
41.   (princ)
    
42. )
    

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

ljfzx

使用的时候 极轴无法生效

bai2000

wowan1314 有个程序，地址自己找

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

77077

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

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

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

77077

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

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

ljfzx

指的是F10的极轴功能

Zrrrrr

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

小毛草

应该为ESC退出才行

Zrrrrr

挺好用的。如果要改成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

挺好的，受教了！