[编程交流] 用于舍入文本的Lisp例程

;4-9-09
;Implements user specified precision on integers with or without text
;used getPrec by CAB
(defun c:NP (/ RtosPrec ss x Number Prec charlist n snumber numlist char strippednumber nnumber NewString)
(vl-load-com)
(setq RtosPrec (getint "Enter Precision to force on all Text and MText Integers:"))
(setq ss (ssget '((-4 . "<OR")(0 . "TEXT")(0 . "MTEXT")(-4 . "OR>"))))
(setq x 0)
(Repeat (sslength ss)
 (progn
  (setq Number (ssname ss x))
(defun getPrec (str)
   (if (vl-string-search "/" str)
     (setq str (vl-string-right-trim "0" (rtos (distof str) 2 ))
   )
   (if (vl-string-search "." str)
     (- (strlen str)(vl-string-search "." str) 1)
     0
   )
 )
(setq Prec (getprec (cdr (assoc 1 (entget Number)))))
(setq charlist (vl-string->list (cdr (assoc 1 (entget Number)))))
(setq n 0 snumber nil)
(setq numlist (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
(repeat (length charlist)
 (setq char (chr (nth n charlist)))
 (if (member char numlist)
  (setq snumber (append snumber (list char)))
 );if
 (setq n (1+ n))
);repeat
(if snumber
(progn
(setq StrippedNumber 0)
(setq n (length snumber))
(setq char 0)
(repeat (- n prec)
 (setq StrippedNumber (+ StrippedNumber (* (atoi (nth char snumber))(expt 10 (1- (- n prec))))))
 (setq n (1- n)
        char (1+ char)
 );setq
);repeat
(setq n prec)
(setq char (length snumber))
(repeat prec
 (setq StrippedNumber (+ StrippedNumber (* (atoi (nth (1- char) snumber))(expt 0.1 n))))
 (setq n (1- n)
        char (1- char)
 );setq
);repeat
(setq snumber (rtos strippednumber 2 prec))
 (setq nnumber (rtos strippednumber 2 rtosprec))
(setq NewString
 (strcat
 (substr (cdr (assoc 1 (entget Number))) 1 (- (length (vl-string->list (cdr (assoc 1 (entget Number)))))(length (vl-string->list snumber))))
 nnumber
 )
)
(entmod (subst (cons 1 NewString)(assoc 1 (entget Number)) (entget Number)))
);progn
);if
);progn
(setq x (1+ x))
);repeat
);defun

(setq fixn
    (cond
        ((= remval 0)  (+ fixedv 0))
        ((= remval 1)  (- fixedv 1))
        ((= remval 2)  (- fixedv 2))
        ((= remval 3)  (- fixedv 3))
        ((= remval 4)  (- fixedv 4))
        ((= remval 5)  (+ fixedv 5))
        ((= remval 6)  (+ fixedv 4))
        ((= remval 7)  (+ fixedv 3))
        ((= remval   (+ fixedv 2))
        ((= remval 9)  (+ fixedv 1))
        )
    )

(if (= remval 0) (setq fixn (+ fixedv 0)))
(if (= remval 1) (setq fixn (- fixedv 1)))
(if (= remval 2) (setq fixn (- fixedv 2)))
(if (= remval 3) (setq fixn (- fixedv 3)))
(if (= remval 4) (setq fixn (- fixedv 4)))
(if (= remval 5) (setq fixn (+ fixedv 5)))
(if (= remval 6) (setq fixn (+ fixedv 4)))
(if (= remval 7) (setq fixn (+ fixedv 3)))
(if (= remval 8 (setq fixn (+ fixedv 2)))
(if (= remval 9) (setq fixn (+ fixedv 1))) 

(setq fixn (eval
           (nth        remval
                '((+ fixedv 0)
                  (- fixedv 1)
                  (- fixedv 2)
                  (- fixedv 3)
                  (- fixedv 4)
                  (+ fixedv 5)
                  (+ fixedv 4)
                  (+ fixedv 3)
                  (+ fixedv 2)
                  (+ fixedv 1)
                 )
           )
         )
     )

(setq fixn (eval (cadr 
           (assoc remval
                '((0 (+ fixedv 0))
                  (1 (- fixedv 1))
                  (2 (- fixedv 2))
                  (3 (- fixedv 3))
                  (4 (- fixedv 4))
                  (5 (+ fixedv 5))
                  (6 (+ fixedv 4))
                  (7 (+ fixedv 3))
                  (8 (+ fixedv 2))
                  (9 (+ fixedv 1))
                 )
           )
         )
     )
     )

(if (and
     (< -1 fixedv 10)
     fixedv) (...))

(if (< remval 5)
   (setq fixn (- fixedv remval))
   (setq fixn (+ fixedv (- 10 remval)))
)