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

玩泥巴 发表于 2019-5-25 15:53:38

本帖最后由玩泥巴于 2019-5-27 10:18 编辑

看到个前辈帖子，功能很好。
但是这个顺号是严格按照图形形心的坐标从上到下，然后从左到右来排序的，怎么能让它在“从上到下”先容许一定的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 发表于 2019-5-25 15:53:39

这个程序很受用感谢分享。我改了一下你试试效果。我现在的容差是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 发表于 2019-5-25 17:45:03

本帖最后由 1291500406 于 2019-5-25 17:53 编辑

(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 发表于 2019-5-25 21:47:27

;将：
(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))
)
      )
      )
   )

玩泥巴 发表于 2019-5-27 09:23:13

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)

玩泥巴 发表于 2019-5-27 09:35:19

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 发表于 2019-5-27 15:06:35

;没有注意到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))
                                    )
                                 )
                  )
         )

页: [1]

明经CAD社区's Archiver

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