讨论 文本+数字递增复制

MENGZE

文本+数字字递增复制,来源于网络，找不到原作者，有个问题请各位优化下！！
就是不能框选，选择对象后来要指认点才能复制，不能默认对象基点！！

(defun c:tt (/ tobj otxt _pf otn ntn ntxt ls en xs ens)
;;;  (defun $ly_getnpf (str / _pat _str n)
;;;    (setq _pat ""
;;;          _str str
;;;    )
;;;    (repeat (setq n (strlen _str))
;;;      (setq _pat (strcat _pat "#"))
;;;    )
;;;    (while (not (wcmatch _str _pat))
;;;      (setq _str (substr _str 2)
;;;            _pat (substr _pat 2)
;;;      )
;;;    )
;;;    (substr str 1 (- n (strlen _str)))
;;;  )
;;;
  (defun $ly_getnpf (str / _pf _str n)
    (setq n 1)
    (while (not _pf)
      (setq _str (substr str n))
      (cond
        ((equal _str "") (setq _pf str))
        ((wcmatch _str "[`.+]*") (setq n (1+ n)))
        ((member (type (read _str)) '(REAL INT))
         (setq _pf (substr str 1 (1- n)))
        )
        (1 (setq n (1+ n)))
      )                                        ; cond
    )                                        ; while
    (if        _pf
      _pf
      ""
    )
  )
  (defun $ly_cntxs (str / xs)
    (cond
      ((wcmatch (strcase str) "*E*") (setq _xs 0))
      ((wcmatch str "*`.*")
       (setq
         _xs (- (strlen str) (vl-string-position (ascii ".") str) 1)
       )
      )
      (1 (setq _xs 0))
    )                                        ; cond
  )

;;;main
  (setvar "cmdecho" 0)
  (or _numb (setq _numb 1.0))
  (if (setq ls (getreal (strcat "\n输入增值或者减值<" (rtos _numb 2) ">: ")))
    (setq _numb ls)
  )
  (setq laste (entlast))
  (if (setq en (car (setq ens (entsel))))
    (progn
      (setq tobj (vlax-ename->vla-object en)
            otxt (vla-get-textstring tobj)
            _pf         ($ly_getnpf otxt)
            otn         (substr otxt (1+ (strlen _pf)))
            xs         ($ly_cntxs otn)
            ozin (getvar "dimzin")
            pt0         (getpoint "\n指定点: ") ;定点
            ppan (mapcar '-
                         pt0
;;;                         (setq pt0 (cadr ens))
                         (cdr (assoc 10 (entget en)))
                 )
      )
      (vlax-release-object tobj)
      (princ "\n下一点: ")
      (command "copy" en "" "m" pt0 pause)
      (while (= 1 (getvar "cmdactive"))
        (command "")
        (if (/= (setq en (entlast)) laste)
          (progn
            (setq tobj (vlax-ename->vla-object en)
                  opt  (mapcar '+ (cdr (assoc 10 (entget en))) ppan)
            )
            (setvar "dimzin" 0)
            (setq otn  (rtos (+ (atof otn) _numb) 2 xs)
                  ntxt (strcat _pf otn)
            )
            (setvar "dimzin" ozin)
            (vla-put-textstring tobj ntxt)
            (vlax-release-object tobj)
            (command "copy" en "" "m" opt pause)
          )
        )
      )
    )
  )                                        ;if
  (gc)
  (princ)
)