连续复制3.0(解决属性块问题)

langjs

;;; __________________________________________
;;; 连续复制3.0     langjs         2021.07.25
;;; 命令:fz      右键默认距离复制  esc键退出
;;; __________________________________________
(defun c:fz (/ #err4 $orr d en p0 p1 r snap ss)
  (defun ssnext (en / ss)
    (setq ss (ssadd))
    (while (setq en (entnext en))
      (if (not (member (cdr (assoc 0 (entget en))) (list "ATTRIB" "VERTEX" "SEQEND")))
        (setq ss (ssadd en ss)))) ss)
  (defun #err4 (s)
    (command ".UNDO" "E")
    (setvar "osmode" snap)
    (setq *error* $orr))
  (setq snap (getvar "osmode"))
  (setvar "cmdecho" 0)
  (setq $orr *error* *error* #err4 )
  (if (setq ss (ssget))
    (if (setq p0 (getpoint "\n指定基点:"))
      (progn
        (while t
          (command ".UNDO" "BE")
          (princ "\n指定下一点或距离:")
          (if d (progn (setvar "osmode" 0) (princ (strcat "<" (rtos d) ">:"))))
          (setq en (entlast))
          (command ".copy" ss "" p0 pause)
          (command ".erase" (ssnext en) "")
          (setq p1 (getvar "lastpoint"))
          (if (equal p0 p1 1e-8)
            (setq p1 (polar p0 r d))
            (setq d (distance p0 p1)  r (angle p0 p1)))
          (if (not (equal p0 p1 1e-8))
            (progn
              (setq en (entlast))
              (command ".copy" ss "" p0 p1)
              (setq ss (ssnext en)  p0 p1 ) ) )
          (command ".UNDO" "E")))))
  (setq *error* $orr)
  (princ)
)

奥特蛋

tryhi 发表于 2016-3-27 23:31
写得不错，稍微修改了下后自用，主要改了两个地方，复制时保持原有的捕捉设置，不强制设置为0，还有就是复 ...

想改为：空格键按上次的距离和方向复制图元，右键退出不知道怎么改

tryhi

2. ;;; __________________________________________
   
3. ;;; 连续复制     改编自langjs         2016.03.27
   
4. ;;; 命令:fz      右键默认距离复制  esc键退出
   
5. ;;; __________________________________________
   
6. (defun c:fz (/ *error* d en p0 p1 p2 r snap ss ssnext)
   
7.   (defun ssnext (en / ss)
   
8.     (setq ss (ssadd))
   
9.     (while (setq en (entnext en))(ssadd en ss))
   
10.         )
    
11.   (defun *error* (s)(command ".UNDO" "E"))
    
12.   (setq snap (getvar "osmode"))
    
13.   (setvar "cmdecho" 0)
    
14.   (if (setq ss (ssget))
    
15.     (if (setq p0 (getpoint "\n指定基点:"))
    
16.       (progn(command ".UNDO" "BE")
    
17.         (while t (princ "\n指定下一点或距离:")
    
18.           (if d (princ (strcat "<" (rtos d) ">:")))
    
19.           (setq en (entlast))
    
20.           (command ".copy" ss "" p0 pause)
    
21.           (setq p1 (getvar "lastpoint")p2 (mapcar '+ p1 p1))
    
22.           (if (equal p0 p1)
    
23.                                                 (progn
    
24.                                                         (setq p1 (polar p0 r d))
    
25.                                                         (if (< snap 16384)(setvar "osmode" (+ snap 16384)))
    
26.                                                         (command ".move" (ssnext en) "" p2 p1)
    
27.                                                         (setvar "osmode" snap)
    
28.                                                         (setq snap (getvar "osmode"))
    
29.                                                 )
    
30.                                                 (setq d (distance p0 p1) r (angle p0 p1)))
    
31.           (setq ss (ssnext en) p0 p1 )
    
32.                                 )
    
33.                         )
    
34.                 )
    
35.         )
    
36.   (princ)
    
37. )

;;; __________________________________________<br /> ;;; 连续复制     改编自langjs         2016.03.27<br /> ;;; 命令:fz      右键默认距离复制  esc键退出<br /> ;;; __________________________________________<br /> (defun c:fz (/ *error* d en p0 p1 p2 r snap ss ssnext)<br />   (defun ssnext (en / ss)<br />     (setq ss (ssadd))<br />     (while (setq en (entnext en))(ssadd en ss))<br />         )<br />   (defun *error* (s)(command ".UNDO" "E"))<br />   (setq snap (getvar "osmode"))<br />   (setvar "cmdecho" 0)<br />   (if (setq ss (ssget))<br />     (if (setq p0 (getpoint "\n指定基点:"))<br />       (progn(command ".UNDO" "BE")<br />         (while t (princ "\n指定下一点或距离:")<br />           (if d (princ (strcat "<" (rtos d) ">:")))<br />           (setq en (entlast))<br />           (command ".copy" ss "" p0 pause)<br />           (setq p1 (getvar "lastpoint")p2 (mapcar '+ p1 p1))<br />           (if (equal p0 p1) <br />                                                 (progn<br />                                                         (setq p1 (polar p0 r d))<br />                                                         (if (< snap 16384)(setvar "osmode" (+ snap 16384)))<br />                                                         (command ".move" (ssnext en) "" p2 p1)<br />                                                         (setvar "osmode" snap)<br />                                                         (setq snap (getvar "osmode"))<br />                                                 )<br />                                                 (setq d (distance p0 p1) r (angle p0 p1)))<br />           (setq ss (ssnext en) p0 p1 )<br />                                 )<br />                         )<br />                 )<br />         )<br />   (princ)<br /> )

写得不错，稍微修改了下后自用，主要改了两个地方，复制时保持原有的捕捉设置，不强制设置为0，还有就是复制的时候不采取先复制后删除的方式，这样对于大量图形可以明显提高速度。还有就是退出函数你这样写有点多余，直接局部定义*error*即可

qazxswk

奥特蛋 发表于 2019-1-24 20:31
想改为：空格键按上次的距离和方向复制图元，右键退出不知道怎么改

看看我的帖子 http://bbs.mjtd.com/forum.php?mod=viewthread&tid=190502
把我的帖子中：(member bb '((2 13)(2 70)(2 102)))  改为 (member bb '((2 32)))
((member bb '((2 32)))(exit))  改为  ((=(car bb) 25)(exit))
这样就实现你的要求了。至于方向键复制图元，实现不了，因为方向键没有grread对应按键值

nyistjz

yoyoho

感谢分享学习!!!!

ymcui

海盗曹

mark 一下，以备不时之需

《真水无香》

好东西，谢谢分享

《真水无香》

怎么复制下来用不了

《真水无香》

使用的时候，命令栏有乱码，请问这个是什么原因？

zhaoyafei1

需要成品yige哈哈