[分享] 数字递增拷贝LISP程序
;;;--数字递增拷贝----------------------------------------------------
(defun c:copynum (/ num-en-name num-en-date
entypenum num-date base-pt pt1
pt2 delt-xdelt-y delt-z x
y z num-pt int-type
)
;(SetErr)
(if (= delt-num nil)
(setq delt-num 1)
) ;_end if
(princ "\n请输入增量值 [1] lt; ")
(princ delt-num)
(princ " gt;:")
(if (not (setq #delt-num (getint)))
(setq delt-num delt-num)
(setq delt-num #delt-num)
)
(if (not
(setq num-en-name (car (entsel "\n请选择一个数字lt;退出gt;:")))
)
(exit)
)
(redraw num-en-name 3)
(setq num-en-date (entget num-en-name))
(setq entype (cdr (assoc 0 num-en-date)))
(setq int-type (type 1))
(if (or (= entype "TEXT")
(= entype "MTEXT")
;;(= entype "ATTDEF")
)
(progn
(if (eq (type (setq num (read (cdr (assoc 1 num-en-date)))))
int-type
)
(progn
(setq pt1 (getpoint "\n请指定基准点:"))
(cond
((and (= entype "TEXT")
(or (= (cdr (assoc 72 num-en-date)) 1)
(= (cdr (assoc 73 num-en-date)) 2)
(= (cdr (assoc 72 num-en-date)) 4)
(and
(= (cdr (assoc 72 num-en-date)) 0)
(/= (cdr (assoc 73 num-en-date)) 0)
)
)
)
(setq base-pt (cdr (assoc 11 num-en-date)))
(setq x (car base-pt)
y (cadr base-pt)
z (caddr base-pt)
)
(while (setq pt2 (getpoint pt1 "\n请指定第二点:"))
(setq delt-x (- (car pt2) (car pt1))
delt-y (- (cadr pt2) (cadr pt1))
delt-z (- (caddr pt2) (caddr pt1))
)
(setq num-pt (list 11 (delt-x x) (delt-y y) (delt-z z))
num(delt-num num)
num-date (cons 1 (itoa num))
)
(setq num-en-date
(subst num-date (assoc 1 num-en-date) num-en-date)
)
(setq num-en-date
(subst num-pt (assoc 11 num-en-date) num-en-date)
)
(entmake num-en-date)
)
)
((and (= entype "TEXT")
(or (= (cdr (assoc 72 num-en-date)) 3)
(= (cdr (assoc 72 num-en-date)) 5)
)
)
(setq base-pt (cdr (assoc 11 num-en-date))
x (car base-pt)
y (cadr base-pt)
z (caddr base-pt)
)
(setq base-pt2 (cdr (assoc 10 num-en-date))
x2 (car base-pt2)
y2 (cadr base-pt2)
z2 (caddr base-pt2)
)
(while (setq pt2 (getpoint pt1 "\n请指定第二点:"))
(setq delt-x (- (car pt2) (car pt1))
delt-y (- (cadr pt2) (cadr pt1))
delt-z (- (caddr pt2) (caddr pt1))
)
(setq num-pt (list 11 (delt-x x) (delt-y y) (delt-z z))
num-pt2(list 10 (delt-x x2) (delt-y y2) (delt-z z2))
num(delt-num num)
num-date (cons 1 (itoa num))
)
(setq num-en-date
(subst num-date (assoc 1 num-en-date) num-en-date)
)
(setq num-en-date
(subst num-pt (assoc 11 num-en-date) num-en-date)
)
(setq num-en-date
(subst num-pt2 (assoc 10 num-en-date) num-en-date)
)
(entmake num-en-date)
)
)
(t
(setq base-pt (cdr (assoc 10 num-en-date)))
(setq x (car base-pt)
y (cadr base-pt)
z (caddr base-pt)
)
(while (setq pt2 (getpoint pt1 "\n请指定第二点:"))
(setq delt-x (- (car pt2) (car pt1))
delt-y (- (cadr pt2) (cadr pt1))
delt-z (- (caddr pt2) (caddr pt1))
)
(setq num-pt (list 10 (delt-x x) (delt-y y) (delt-z z))
num(delt-num num)
num-date (cons 1 (itoa num))
)
(setq num-en-date
(subst num-date (assoc 1 num-en-date) num-en-date)
)
(setq num-en-date
(subst num-pt (assoc 10 num-en-date) num-en-date)
)
(entmake num-en-date)
)
)
) ;_end cond
)
(alert "＊＊不是数字＊＊")
)
)
(alert " ＊＊请选择数字＊＊")
)
(redraw num-en-name 4)
;(ReErr)
(princ)
)
