如何增加带记忆的复制，空格确认上一步的距离
请教大神们，我下面的这个程序如何增加带记忆的复制呢，类似图片的这个效果的，默认效果是要重复不断的输入指定距离的，步骤有点多了，我想能空格确认上一次的距离那就方便多啦(defun c:tt5(/ ent ss)
(setq n1 10)
(defun *error* (msg)
(if ss (sshighlight ss 4)) ;取消亮显
(SSSETFIRST NIL)
(princ "error:")
(princ msg)
)
(setq a (cadr (ssgetfirst)))
(if a
(setq ss a)
(setq ss (ssget))
)
(setvar "cmdecho" 0)
(command "undo" "g")
;;预选择函数段必须在这一句之前，否则无效
(setq pt Nil)
(if (< (sslength ss) n1)(SSSETFIRST NIL SS))
(sshighlight ss 3)
(setq p1 (getpoint "指定基点: "))
(princ "\n")
(if p1
(progn
(while (not (equal p1 pt 1e-4))
(setq ent (entlast))
(setq pt p1)
(princ "指定下一点: ")
(vl-cmdf "copy" ss "" "non" pt pause)
(setq tempss ss)
(setq ss (entbackss ent))
(setq p1 (getvar "lastpoint"))
)
(command "._erase" ss "")
(command "select" tempss "")
)
(princ "\n未指定基准点，程序结束\n")
)
)
;控制选择集亮显
(defun sshighlight (ss n / slen ient )
(setq slen (sslength ss) i 0 )
(while (ssname ss i)
(setq ent (ssname ss i))
(redraw ent n);亮显
(setq i (1+ i))
)
T
)
本帖最后由 langjs 于 2021-12-17 11:58 编辑
修订了复制属性块出错
;;; __________________________________________
;;; 连续复制3.0 langjs 2021.12.17
;;; 命令: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)
)
langjs 发表于 2021-9-19 21:09
;;; __________________________________________
;;; 连续复制2.0 langjs 2016.03.27
;;;...
狼大侠太给力了，这个折腾了好久，总算有一个完美的效果了 langjs 发表于 2021-9-19 21:09
;;; __________________________________________
;;; 连续复制2.0 langjs 2016.03.27
;;;...
狼大师，反馈几个问题哈 (equal p0 p1) 在USC下输入距离然后空格复制时会有问题的，改成这个(equal p0 p1 1e-8)貌似就可以了，不知道啥原因，还有就是涉及到属性块的单体，单独复制的属性块，就会显示未知命令，然后自动中断了，如果属性块在其他编组内部，编组功能打开的，或者在其他普通块的内部就没这个问题，不知道为什么，只要属性块单独存在的，一复制就会出错了 magicheno 发表于 2021-9-21 22:15
狼大师，反馈几个问题哈 (equal p0 p1) 在USC下输入距离然后空格复制时会有问题的，改成这个(equal p0 p1 ...
试了，我这也有这问题。 langjs 发表于 2021-9-19 21:09
;;; __________________________________________
;;; 连续复制2.0 langjs 2016.03.27
;;;...
狼大师，属性块出错影响挺大的额，每天都是跟属性块打交道的 langjs 发表于 2021-9-19 21:09
;有个新一点的版本
;;; __________________________________________
;;; 连续复制3.0 langjs ...
狼大师，不知道为什么属性块还是不行呢，一复制就出问题的，不知道为啥呢
狼大侠的程序，好用！ magicheno 发表于 2021-9-23 12:42
狼大师，不知道为什么属性块还是不行呢，一复制就出问题的，不知道为啥呢
修订了一个新版本，解决属性块出错问题，你试试 langjs 发表于 2021-12-17 12:00
修订了一个新版本，解决属性块出错问题，你试试
感谢狼大师，试过了可以的，效果非常好