求四至坐标小数位数选择功能

kdanqu

新到小白，求大佬帮忙加一个输出坐标保留小数位数的功能。查过资料，和平时见到的四舍五入函数好像都不一样，造成小白不知道如何修改。
代码如下
;; ZDT(四至标注)
(defun err (msg)
  (princ msg)
  (restore)
)

(defun init ()
  (command "_.undo" "be")
  (setq dimzin (getvar "dimzin"))
  (setvar "dimzin" 1)
  (setq os (getvar "osmode"))
  (setvar "osmode" 0)
  (setvar "cmdecho" 0)
  (setq errtmp *error*)
  (setq *error* err)
)

(defun restore ()
  (setq *error* errtmp)
  (setvar "dimzin" dimzin)
  (setvar "osmode" os)
  (command "_.undo" "e")
)

(defun xl-sort (lst fun / nlst)
  (foreach n lst (setq nlst (xl-isort n nlst fun)))
)
(defun xl-isort        (item lst fun / k nlst)
  (setq        k    T
        nlst (apply 'append
                    (mapcar '(lambda (x)
                               (if (and K ((eval fun) item x))
                                 (progn (setq k nil) (list item x))
                                 (list x)
                               )
                             )
                            lst
                    )
             )
  )
  (if k
    (append lst (list item))
    nlst
  )
)

(defun MakeText        (pt Height Ang str / dxf)
  (setq        dxf '((0 . "TEXT")
              (100 . "AcDbEntity")
              (67 . 0)
              (410 . "Model")
              (8 . "JZP")
              (100 . "AcDbText")
             )
        dxf (append dxf
                    (list (cons 10 pt) (cons 40 height) (cons 50 Ang) (cons 1 str))
            )
        dxf (append dxf
                    '((41 . 0.8)
                      (51 . 0.0)
                      (71 . 0)
                      (72 . 0)
                      (210 0.0 0.0 1.0)
                      (100 . "AcDbText")
                      (73 . 0)
                     )
            )
  )
  (entmake dxf)
)
(defun MakeText2 (pt Height Ang str / dxf)
  (setq        dxf '((0 . "TEXT")
              (100 . "AcDbEntity")
              (67 . 0)
              (410 . "Model")
              (8 . "JZP")
              (100 . "AcDbText")
              (10 0.0 0.0 0.0)
             )
        dxf (append dxf
                    (list (cons 11 pt) (cons 40 height) (cons 50 Ang) (cons 1 str))
            )
        dxf (append dxf
                    '((41 . 0.8)
                      (51 . 0.0)
                      (71 . 0)
                      (72 . 1)
                      (210 0.0 0.0 1.0)
                      (100 . "AcDbText")
                      (73 . 2)
                     )
            )
  )
  (entmake dxf)
)
(defun MakeText3 (pt Height Ang str / dxf)
  (setq        dxf '((0 . "TEXT")
              (100 . "AcDbEntity")
              (67 . 0)
              (410 . "Model")
              (100 . "AcDbText")
              (10 0.0 0.0 0.0)
             )
        dxf (append dxf
                    (list (cons 11 pt)
                          (cons 40 height)
                          (cons 50 Ang)
                          (cons 1 (strcat "J" str))
                    )
            )
        dxf (append dxf
                    '((41 . 0.8)
                      (51 . 0.0)
                      (71 . 0)
                      (72 . 1)
                      (210 0.0 0.0 1.0)
                      (100 . "AcDbText")
                      (73 . 2)
                     )
            )
  )
  (entmake dxf)
)
(defun OpPts (pts pt h scal / pti ptn ptc ang len params pts2 i)
  (setq pts_tmp nil)
  (if (equal (distance (car pts) (last pts)) 0 0.00000000001)
    (setq pts (cdr pts))
  )
  (setq        pts2 (xl-sort pts
                      '(lambda (e1 e2)
                         (< (abs (- (angle pt e1) (/ pi 4))) (abs (- (angle pt e2) (/ pi 4))))
                       )
             )
  )
  (while (not (equal (car pts) (car pts2)))
    (setq pts (append (cdr pts) (list (car pts))))
  )
  (setq pti (car pts))
  (foreach ptn (append (cdr pts) (list (car pts)))
    (setq ptc (list (/ (+ (car ptn) (car pti)) 2.0)
                    (/ (+ (cadr ptn) (cadr pti)) 2.0)
              )
    )
    (setq ang (angle pti ptn))
    (setq len (distance ptn pti))
    (setq params (append params (list (list ang ptc len))))
    (setq pti ptn)
  )
  (setq i 1)
  (mapcar '(lambda (e)
             (MakeText2        (polar (cadr e) (+ (/ pi 2) (car e)) (* 0.75 h))
                        h
                        (if (and (> (car e) (/ pi 2.0)) (< (car e) (* pi 1.5)))
                          (- (car e) pi)
                          (car e)
                        )
                        (rtos (last e) 2 2)
             )
           )
          params
  )
)
(defun GetVer (ent / pts ents)
  (while (/= (cdr (assoc 0 (setq ents (entget (setq ent (entnext ent))))))
             "SEQEND"
         )
    (setq pts (append pts (list (cdr (assoc 10 ents)))))
  )
  pts
)
(defun GETPL (ED / ENTS PTS)
  (setq ENTS (entget ED))
  (while (setq ENTS (member (assoc 10 ENTS) ENTS))
    (setq PTS (append PTS (list (cdar ENTS))))
    (setq ENTS (CDR ENTS))
  )
  PTS
)
(defun Order (pts / n pt ang angn angi angAll pt pti)
  (setq n (length pts))
  (setq        pt (list (/ (apply '+ (mapcar 'car pts)) n)
                 (/ (apply '+ (mapcar 'cadr pts)) n)
           )
  )
  (setq ang (angle pt (car pts)))
  (setq angAll 0)
  (foreach pti (append (cdr pts) (list (car pts)))
    (setq angn (angle pt pti))
    (setq angi (- angn ang))
    (cond
      ((> angi pi) (setq angi (- angi (* pi 2))))
      ((< angi (- pi)) (setq angi (+ angi (* pi 2))))
    )
    (setq angAll (+ angAll angi))
    (setq ang angn)
  )
  (cond
    ((equal angAll 0 1) (list pt nil))
    ((> angAll 0) (list pt nil))
    ((< angAll 0) (list pt t))
  )
)
(defun DoubleM (ent / ents pt pts l h x y h2)
  (setq ents (entget ent))
  (if (= (cdr (assoc 0 ents)) "TEXT")
    (progn
      (setq pt (cdr (assoc 10 ents)))
      (setq pts (textbox ents))
      (setq l (caadr pts))
      (setq h (cdr (assoc 40 ents)))
      (setq x (+ l (* h 0.4)))
      (setq y (* h 0.7))
      (setq h2 (* h 0.5))
      (MakeText (list (+ (car pt) x) (+ (cadr pt) y)) h2 0 "2")
    )
  )
)


(defun c:zdt ()
  (init)
  (setq ent (car (entsel "\n请选择图形...")))
  (setq p0 (getpoint "\n表格基点<退出>: "))
  (setq ptn0 (zdt1 ent))
  (setq pts (getpl ent))
  (if (cadr (setq pt (Order (reverse pts))))
    (setq pts (reverse pts))
  )
  (setq pt (car pt))
  (command "_.pedit" ent "w" 0 "")
  (vla-put-color (vlax-ename->vla-object ent) 1)
  (OpPts pts pt 1.5 1)
  (bg000 ptn0 p0)
  (restore)
  (princ)
)

(defun zdt1 (ent / pps wn1p di1l di1s)
  (setq        pps (mapcar 'cdr
                    (vl-remove-if '(lambda (x) (/= (car x) 10)) (entget ent))
            )
  )
  (or
    (< (apply '+
              (mapcar '(lambda (x y) (- (* (car x) (cadr y)) (* (cadr x) (car y))))
                      (cons (last pps) pps)
                      pps
              )
       )
       0
    )
    (setq pps (reverse pps))
  )
  (setq        wn1p (list (apply 'min (mapcar 'car pps)) (apply 'max (mapcar 'cadr pps)))
        di1L (mapcar (function (lambda (pt0) (distance pt0 wn1p))) pps)
        di1s (vl-position (apply 'min di1L) di1L)
  )
  (or (= di1s 0)
      (repeat di1s
        (setq pps (append (cdr pps) (list (car pps))))
      )
  )
  (setq        di1s 0
        di1l (append pps (list (car pps)))
  )

  (foreach pt0 pps
    (entmakex
      (list '(0 . "TEXT")
            '(100 . "AcDbEntity")
            '(67 . 0)
            '(8 . "JZP")
            '(410 . "Model")
            '(100 . "AcDbText")
            '(10 0.0 0.0 0.0)
            (cons 11 (polar pt0 (+ (angle pt0 (cadr di1l)) (* pi 0.5)) 2))
            (cons 40 2.0)
            (cons 1 (strcat "J" (itoa (setq di1s (1+ di1s)))))
            '(41 . 0.8)
            '(51 . 0.0)
            '(71 . 0)
            '(72 . 1)
            '(210 0.0 0.0 1.0)
            '(100 . "AcDbText")
            '(73 . 2)
      )
    )
    (setq di1l (cdr di1l))
  )
  pps
)


(defun c:bg ()
  (setq        i   0
        j   0
        s1  (car (entsel "\n选择闭合线: "))
        ent (entget s1)
        pt  (getpoint "\n坐标表放置位置: ")
        x   (car pt)
        y   (cadr pt)
        yn  y
        x4  (- x 10)
        pt4 (list x4 y)
        x1  (+ 18 x4)
        pt1 (list x1 y)
        x2  (+ 46 x4)
        pt2 (list x2 y)
        y9  (+ y 7)
        pt9 (list x4 y9)
  )
  (command "text" pt9 4 0 "坐标成果表")
  (command "text" pt4 4 0 "点号")
  (command "text" pt1 4 0 "横坐标(X)")
  (command "text" pt2 4 0 "纵坐标(Y)")
  (foreach pt ent
    (if        (eq (car pt) 10)
      (progn
        (setq j          (1+ j)
              pe1 (cdr pt)
              yn  (- yn 10)
              pt3 (list x yn)
        )
        (command "text" pe1 3 0 (strcat "J" (itoa j)))
        (liang pe1 pt3 j)
      )
    )
  )
  (setq        x5  (- x4 3.220)
        y5  (+ y 5.2259)
        pt5 (list x5 y5)
        x6  (+ x5 69.1817)
        pt6 (list x6 y5)
  )
  (command "LINE" pt5 pt6 "")
  (setq a (entlast))
  (command "array" a "" "r" (+ j 2) 1 -10)
  (setq y7 (- y5 10))
  (setq pt7 (list x5 y7))
  (command "LINE" pt5 pt7 "")
  (setq a (entlast))
  (command "array" a "" "r" (+ j 1) 2 -10 11)
  (setq pt8 (list x6 y7))
  (command "LINE" pt6 pt8 "")
  (setq a (entlast))
  (command "array" a "" "r" (+ j 1) 2 -10 -30)
  (princ)
)

(defun liang (k pt3 r)
  (setq        yy  (car k)
        xx  (cadr k)
        x1  (car pt3)
        y1  (cadr pt3)
        x1  (+ 28 x1)
        pe1 (list x1 y1)
        xj  (- (car pt3) 10)
        pe2 (list xj y1)
  )
  (command "text" pe2 3 0 r)
  (command "text" pt3 3 0 (rtos xx))
  (command "text" pe1 3 0 (rtos yy))
)

(defun bg000 (ptn pt / a i j pt1 pt2 pt3 pt4 pt5 pt6 pt7 pt8 pt9 x x1 x2 x4 x5 x6 y y5 y7 y9 yn)
  (setq        i   0
        j   0
        x   (car pt)
        y   (cadr pt)
        yn  y
        x4  (- x 10)
        pt4 (list x4 y)
        x1  (+ 18 x4)
        pt1 (list x1 y)
        x2  (+ 46 x4)
        pt2 (list x2 y)
        y9  (+ y 7)
        pt9 (list x4 y9)
  )
  (command "text" pt9 4 0 "坐标成果表")
  (command "text" pt4 4 0 "点号")
  (command "text" pt1 4 0 "横坐标(X)")
  (command "text" pt2 4 0 "纵坐标(Y)")
  (foreach p1 ptn
    (progn
      (setq j        (1+ j)
            yn        (- yn 10)
            pt3        (list x yn)
      )
                                                  ;(command "text" p1 3 0 (strcat "J" (itoa j)))
      (liang p1 pt3 j)
    )
  )
  (setq        x5  (- x4 3.220)
        y5  (+ y 5.2259)
        pt5 (list x5 y5)
        x6  (+ x5 69.1817)
        pt6 (list x6 y5)
  )
  (command "LINE" pt5 pt6 "")
  (setq a (entlast))
  (command "array" a "" "r" (+ j 2) 1 -10)
  (setq y7 (- y5 10))
  (setq pt7 (list x5 y7))
  (command "LINE" pt5 pt7 "")
  (setq a (entlast))
  (command "array" a "" "r" (+ j 1) 2 -10 11)
  (setq pt8 (list x6 y7))
  (command "LINE" pt6 pt8 "")
  (setq a (entlast))
  (command "array" a "" "r" (+ j 1) 2 -10 -30)
  (princ)
)

bssurvey

(defun liang (k pt3 r)                       
  (setq        yy  (car k)                  
        xx  (cadr k)                        
        x1  (car pt3)                        
        y1  (cadr pt3)                       
        x1  (+ 28 x1)                        
        pe1 (list x1 y1)                     
        xj  (- (car pt3) 10)                 
        pe2 (list xj y1)                     
  )                                          
  (command "text" pe2 3 0 r)                 
  (command "text" pt3 3 0 (rtos xx 2 3))     
  (command "text" pe1 3 0 (rtos yy 2 3))     
)                  
這樣就可以了                        

kdanqu

bssurvey 发表于 2021-1-25 09:26
(defun liang (k pt3 r)                       
  (setq        yy  (car k)                  
       ...

感谢大佬帮助！！！！！