如何增加带记忆的复制，空格确认上一步的距离

magicheno

请教大神们，我下面的这个程序如何增加带记忆的复制呢，类似图片的这个效果的，默认效果是要重复不断的输入指定距离的，步骤有点多了，我想能空格确认上一次的距离那就方便多啦
(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 i  ent )
  (setq slen (sslength ss) i 0 )
  (while (ssname ss i)
    (setq ent (ssname ss i))
    (redraw ent n);亮显
    (setq i (1+ i))
  )
  T
)

langjs

修订了复制属性块出错
;;; __________________________________________
;;; 连续复制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)
)

magicheno

langjs 发表于 2021-9-19 21:09
;;; __________________________________________
;;; 连续复制2.0     langjs         2016.03.27
;;;  ...

狼大侠太给力了，这个折腾了好久，总算有一个完美的效果了

magicheno

langjs 发表于 2021-9-19 21:09
;;; __________________________________________
;;; 连续复制2.0     langjs         2016.03.27
;;;  ...

狼大师，反馈几个问题哈 (equal p0 p1) 在USC下输入距离然后空格复制时会有问题的，改成这个(equal p0 p1 1e-8)貌似就可以了，不知道啥原因，还有就是涉及到属性块的单体，单独复制的属性块，就会显示未知命令，然后自动中断了，如果属性块在其他编组内部，编组功能打开的，或者在其他普通块的内部就没这个问题，不知道为什么，只要属性块单独存在的，一复制就会出错了

yanchao316

magicheno 发表于 2021-9-21 22:15
狼大师，反馈几个问题哈 (equal p0 p1) 在USC下输入距离然后空格复制时会有问题的，改成这个(equal p0 p1 ...

试了，我这也有这问题。

magicheno

langjs 发表于 2021-9-19 21:09
;;; __________________________________________
;;; 连续复制2.0     langjs         2016.03.27
;;;  ...

狼大师，属性块出错影响挺大的额，每天都是跟属性块打交道的

magicheno

langjs 发表于 2021-9-19 21:09
;有个新一点的版本
;;; __________________________________________
;;; 连续复制3.0     langjs        ...

狼大师，不知道为什么属性块还是不行呢，一复制就出问题的，不知道为啥呢

xzd716

狼大侠的程序，好用！

langjs

magicheno 发表于 2021-9-23 12:42
狼大师，不知道为什么属性块还是不行呢，一复制就出问题的，不知道为啥呢

修订了一个新版本，解决属性块出错问题，你试试

magicheno

langjs 发表于 2021-12-17 12:00
修订了一个新版本，解决属性块出错问题，你试试

感谢狼大师，试过了可以的，效果非常好