悬赏高手对这个lisp增加个功能

玩泥巴

看到个前辈帖子，功能很好。
但是这个顺号是严格按照图形形心的坐标从上到下，然后从左到右来排序的，怎么能让它在“从上到下”先容许一定的100mm（或用户定义）的误差呢，然后再从左到右顺号呢？？？期待大神帮忙，更新后功能类似于图片中示意。
感谢原帖的xiaodao520 ，langjs，hao3ren ，附源代码如下：
;; 功能： 输出封闭多边形边长及面积 到 EXCEL 文件
(defun c:qq (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:"))
   (defun maketext (txt pt)             ; 生成文字子函数
    (entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.8)))
   )
   (setvar "cmdecho" 0)
   (vl-load-com)
   (setq ss (ssget) ent (entlast))
   (command ".region" ss "")
   (setq ss (ssadd)  lst nil)
   (while (setq ent (entnext ent))
     (if (= (cdr (assoc 0 (entget ent))) "REGION")
       (setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
             m2 (rtos (vla-get-area obj) 2 2) d (rtos (vla-get-perimeter obj) 2 2) lst (cons (list pt m2 d) lst)
       )
     )
   )
   (command ".undo" "")
   (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
   (setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))
   (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "w"))
   (write-line "编号\t周长(mm)\t面积(mm2)" f)
   (setq i 1)
   (foreach x lst
     (setq pt (car x) m2 (cadr x) d (caddr x))
     (maketext (strcat Textbh (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
     (maketext (strcat "L=" d "mm") pt)
     (maketext (strcat "S=" m2 "mm2") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
     (write-line (strcat (strcat Textbh (itoa i)) "\t" d "\t" m2) f)
     (setq i (1+ i))
   )
   (close f)
   (princ)
)

yanshengjiang

这个程序很受用  感谢分享。 我改了一下你试试效果。我现在的容差是10米


;; 功能： 输出封闭多边形边长及面积 到 EXCEL 文件
(defun c:qq (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:")
Textbh (getstring "\n输入编号前缀:"))
   (defun maketext (txt pt)             ; 生成文字子函数
    (entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight) (cons 1 txt) '(41 . 0.8)))
   )
   (setvar "cmdecho" 0)
   (vl-load-com)
   (setq ss (ssget) ent (entlast))
   (command ".region" ss "")
   (setq ss (ssadd)  lst nil)
   (while (setq ent (entnext ent))
     (if (= (cdr (assoc 0 (entget ent))) "REGION")
       (setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
             m2 (rtos (vla-get-area obj) 2 2) d (rtos (vla-get-perimeter obj) 2 2) lst (cons (list pt m2 d) lst)
       )
     )
   )
   (command ".undo" "")
;;;   (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
;;;   (setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))
  (setq lst (vl-sort lst '(lambda(a b)
                                         (if (equal (cadr (car a)) (cadr (car b)) 10)
                                           (< (car (car a)) (car (car b)))
                                             (> (cadr (car a)) (cadr (car b)))
                                             
                                         )
                                     )
                       )
            )
   (setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "w"))
   (write-line "编号\t周长(mm)\t面积(mm2)" f)
   (setq i 1)
   (foreach x lst
     (setq pt (car x) m2 (cadr x) d (caddr x))
     (maketext (strcat Textbh (itoa i)) (list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))
     (maketext (strcat "L=" d "mm") pt)
     (maketext (strcat "S=" m2 "mm2") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
     (write-line (strcat (strcat Textbh (itoa i)) "\t" d "\t" m2) f)
     (setq i (1+ i))
   )
   (close f)
   (princ)
)

1291500406

(defun c:qq (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:")Textbh (getstring "\n输入编号前缀:"))
(defun maketext (txt pt)(entmake (list '(0 . "TEXT") (cons 62 1) (cons 10 pt) (cons 40 TextHeight)(cons 1 txt) '(41 . 0.8))))
(setvar "cmdecho" 0)(vl-load-com)(setq ss (ssget) ent (entlast))(command ".region" ss "")(setq ss (ssadd)  lst nil)
(while (setq ent (entnext ent))(if (= (cdr (assoc 0 (entget ent))) "REGION")
(setq obj (vlax-ename->vla-object ent) pt (vlax-safearray->list (vlax-variant-value (vla-get-centroid obj)))
m2 (rtos (vla-get-area obj) 2 2) d (rtos (vla-get-perimeter obj) 2 2) lst (cons (list pt m2 d) lst))))
(command ".undo" "")(setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
(setq f (getfiled "指定输出文件路径" "" "xls" 1) f (open f "w"))(write-line "编号\t周长(mm)\t面积(mm2)" f)(setq i 1)
(foreach x lst(setq pt (car x) m2 (cadr x) d (caddr x))(maketext (strcat Textbh (itoa i))
(list (car pt) (+ (cadr pt) (* 1.2 TextHeight))))(maketext (strcat "L=" d "mm") pt)
(maketext (strcat "S=" m2 "mm2") (list (car pt) (- (cadr pt) (* 1.2 TextHeight))))
(write-line (strcat (strcat Textbh (itoa i)) "\t" d "\t" m2) f)(setq i (1+ i)))(close f)(princ))

yshf

;将 ：
  (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
   (setq lst (vl-sort lst (function (lambda (x y)(> (cadr (car x)) (cadr (car y)))))))          
;改为如下：

            (setq lst (vl-sort lst '(lambda(a b)
                                         (if (equal (car a) (car b) 0.100)
                                             (> (cadr a) (cadr b))
                                             (< (car a) (car b))
                                         )
                                     )
                       )
            )

玩泥巴

yshf 发表于 2019-5-25 21:47
;将 ：
  (setq lst (vl-sort lst (function (lambda (x y)(< (car (car x)) (car (car y)))))))
   (set ...

错误: 用于比较的参数类型不正确: (1.38146e+006 -552555.0) (1.61655e+006 -563187.0)

玩泥巴

1291500406 发表于 2019-5-25 17:45
(defun c:qq (/ d ent f i lst m2 obj pt ss txt x y)
(setq TextHeight (getdist "\n输入标注文字高度:") ...

这个仅考虑了从左到右排序，我还是要兼顾从上到下原则的。只是不需要严格按照从上到下，同一水平线的允许一定的误差。我那个更新图里没表达出下一排X7，X8，X9.........。

yshf

;没有注意到lst的子表元是(点 面积字符串 周长字符串)
;应改为如下:
            (setq lst (vl-sort lst '(lambda(a b)
                                         (if (equal (caar a) (caar b) 0.100)
                                             (> (cadar a) (cadar b))
                                             (< (caar a) (caar b))
                                         )
                                     )
                       )
            )