langjs 发表于 2016-3-27 21:53:39

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

本帖最后由 langjs 于 2022-6-9 21:35 编辑


;;; __________________________________________
;;; 连续复制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)
)



奥特蛋 发表于 2019-1-24 20:31:57

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

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

tryhi 发表于 2016-3-27 23:31:37

本帖最后由 tryhi 于 2016-4-4 17:02 编辑

;;; __________________________________________
;;; 连续复制   改编自langjs         2016.03.27
;;; 命令:fz      右键默认距离复制esc键退出
;;; __________________________________________
(defun c:fz (/ *error* d en p0 p1 p2 r snap ss ssnext)
(defun ssnext (en / ss)
    (setq ss (ssadd))
    (while (setq en (entnext en))(ssadd en ss))
      )
(defun *error* (s)(command ".UNDO" "E"))
(setq snap (getvar "osmode"))
(setvar "cmdecho" 0)
(if (setq ss (ssget))
    (if (setq p0 (getpoint "\n指定基点:"))
      (progn(command ".UNDO" "BE")
      (while t (princ "\n指定下一点或距离:")
          (if d (princ (strcat "<" (rtos d) ">:")))
          (setq en (entlast))
          (command ".copy" ss "" p0 pause)
          (setq p1 (getvar "lastpoint")p2 (mapcar '+ p1 p1))
          (if (equal p0 p1)
                                                (progn
                                                      (setq p1 (polar p0 r d))
                                                      (if (< snap 16384)(setvar "osmode" (+ snap 16384)))
                                                      (command ".move" (ssnext en) "" p2 p1)
                                                      (setvar "osmode" snap)
                                                      (setq snap (getvar "osmode"))
                                                )
                                                (setq d (distance p0 p1) r (angle p0 p1)))
          (setq ss (ssnext en) p0 p1 )
                              )
                        )
                )
      )
(princ)
)写得不错，稍微修改了下后自用，主要改了两个地方，复制时保持原有的捕捉设置，不强制设置为0，还有就是复制的时候不采取先复制后删除的方式，这样对于大量图形可以明显提高速度。还有就是退出函数你这样写有点多余，直接局部定义*error*即可

qazxswk 发表于 2024-6-28 16:44:25

奥特蛋 发表于 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 发表于 2016-3-28 00:17:49

yoyoho 发表于 2016-3-28 08:46:21

感谢分享学习!!!!

ymcui 发表于 2016-3-28 08:55:27

海盗曹 发表于 2016-3-28 11:01:49

mark 一下，以备不时之需

《真水无香》 发表于 2016-3-30 11:47:10

好东西，谢谢分享

《真水无香》 发表于 2016-3-31 09:36:59

怎么复制下来用不了

《真水无香》 发表于 2016-3-31 10:08:54

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

zhaoyafei1 发表于 2016-3-31 21:20:41

需要成品yige哈哈
页: [1] 2 3 4 5
查看完整版本: 连续复制3.0(解决属性块问题)