求大神帮忙解决相同矩形编号问题

那个猎人

本人小菜鸟一只，因为板块提料问题，想自动生成矩形板的宽和高和编号，标注到板块中心处。
现有两个问题不能解决，想请教诸位大神
1.怎样让文字居中标注（我写的是文字的左下角的插入点是矩形中心）
2.怎样让相同高和宽的矩形编号一致（我写的编号是顺次排列）
本人代码比较笨哈。
代码如下：
(defun c:hhh()
        (vl-load-com)
        (setq texth 200)
        (setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))
        (repeat (setq i (sslength recs))
        (setq ent (entget (ssname recs (setq i (1- i))))
              lst '()
                  e (cdr(car ent))
                  area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))
                  )
    (foreach n ent
                        (if (= (car n) 10)
                                (setq lst (cons (cdr n) lst));遍历边界组合，将顶点存入lst内
                        )
        )
        (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd
        (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标
        (setq pcen1 (/ (+ pa1 pc1) 2))
        (setq pcen2 (/ (+ pa2 pc2) 2))
        (setq pcen (list pcen1 pcen2))
        (if (= pa1 pb1)
             (progn
                 (if (and (= pa1 pb1) (= pb2 pc2) (= pc1 pd1) (= pd2 pa2));判断是否为矩形
                 (progn
                 (setq w (abs (- pa1 pd1)))
                 (setq h (abs (- pb2 pa2)))
                 (setq ww (rtos w 2 0))
                 (setq hh (rtos h 2 0))
                 (setq ii (rtos i 2 0))
                 (setq wxh (strcat ww "*" hh "-" ii))
                 (entmake (list '(0 . "TEXT") (cons 1 wxh) (cons 10 pcen) (cons 40 texth)))
                 )
                 (print "非矩形")
                 )
                 )
                 (progn
                 (if (and (= pa2 pb2) (= pb1 pc1) (= pc2 pd2) (= pd1 pa1))
                 (progn
                 (setq w (abs (- pb1 pa1)))
                 (setq h (abs (- pd2 pa2)))
                 (setq ww (rtos w 2 0))
                 (setq hh (rtos h 2 0))
                 (setq ii (rtos i 2 0))
                 (setq wxh (strcat ww "*" hh "-" ii))
         (entmake (list '(0 . "TEXT") (cons 1 wxh) (cons 10 pcen) (cons 40 texth)))
                 )
                 (print "非矩形")
                 )
                 )
        )
)
        (princ)
)

1028695446

翻译下llsheng_73的回帖
;;选集转图元名列表
(defun SstoEs (ss / a en lst)
  (if ss
    (repeat (setq a (sslength ss))
      (setq a        (1- a)
                                lst        (cons (ssname ss a) lst)
      )
    )
  )
  lst
)
;;多段线顶点列表
(defun plinexy (e / p i)
  (setq i -1)
  (mapcar (function (lambda (x) (list (car x) (cadr x))))
          (reverse ;;正的
                        (repeat (fix (1+ (vlax-curve-getEndParam e)))
                                (setq i (1+ i)
                                        p (cons (vlax-curve-getPointAtParam e i) p);;反的
                                )
                        )
          )
  )
  (if (equal (car p) (last p))
    (reverse (cdr (reverse p)));;如果闭合，则去掉最后一个点
    p
  )
)
(defun ABCOfRectangle (e / pt a b)
  ;;矩形中心及长宽
  (if (and (= (length (setq pt (plinexy e))) 4)
                                (equal
                                        (setq a (distance (car pt) (cadr pt)));;AB
                                        (distance (last pt) (caddr pt));;DC
                                        1e-6
                                )
                                (equal
                                        (setq b (distance (cadr pt) (caddr pt)));;BC
                                        (distance (last pt) (car pt));;DA
                                        1e-6
                                )
                                (equal
                                        (distance (car pt) (caddr pt));;AC
                                        (distance (last pt) (cadr pt));;DB
                                        1e-6
                                )
      );;判断为矩形
    (list
                        (mapcar '(lambda (x) (* x 0.5))
                                (mapcar '+ (car pt) (caddr pt))
                        );;矩形中点
                        (vl-sort (mapcar 'atof (mapcar 'rtos (list a b))) '>);;矩形 '(W H)
    );;'(矩形中心点 (W H))
  )
)

;;数据规整
;;对lst以子表第m项为关键字进行分类,ns为整数时记录第ns项、为表【如'(2 3)】记录表中指定的项（第2项，第3项）、为空或者其它,记录关键字以外所有项
(defun subtotals (lst m ns / myfun a b c)
  (cond
                ((= (type ns) 'LIST)
                        (defun myfun (x) (list (mapcar '(lambda (y) (nth y x)) ns)))
                )
                ((= (type ns) 'INT) (defun myfun (x) (list (nth ns x))))
                (t (defun myfun (x) (list (vl-remove c x))))
  )
  (foreach x lst
    (setq a (if        (setq c        (nth m x)
                                                                        b        (assoc c a)
                                                                );;搜索主键中的数据
                                                        (subst (append b (myfun x)) b a);;主键相同，次键并入
                                                        (append a (list (append (list c) (myfun x))));;新建一个以关键字为主键，记录项为次键的新表，，比如以子表的第二项(W H),为主，然后以第一项的中心点为次键的新表，并合并
                                                )
    )
  )
)
;;说实话这个函数有点炫技的意味
(defun maketxt(argments / InsOrDel)
        ;;argments:(list pt txt la style color h hz jz z ro) ;;txt后边的图层，字体可省       
        ;{在指定位置删除或插入元素mod为要插入的元素为空时删除第pos项}
  (defun InsOrDel(lst pos mod / qlst a hlst)               
    (setq a -1)
    (setq hlst (vl-member-if-not
                                                                 '(lambda (x)
                                                                                (setq a (1+ a))
                                                                                (if        (= a pos)
                                                                                        nil
                                                                                        (setq qlst (cons x qlst))
                                                                                )
                                                                        )
                                                                 lst
                                                         )
    )
    (if        mod
      (apply 'append (list (reverse (cons mod qlst)) hlst))
      (apply 'append (list (reverse qlst) (cdr hlst)))
    )
  )
        (setq        argments
                (if (or (/= (type (nth 2 argments)) 'str)
                                        (null (tblsearch "layer" (nth 2 argments)))
                                )
                        (InsOrDel argments 2 (getvar 'clayer))
                        argments
                )
                argments
                (if (or (/= (type (nth 3 argments)) 'str)
                                        (null (tblsearch "style" (nth 3 argments)))
                                )
                        (InsOrDel argments 3 "Standard")
                        argments
                )
        )
        (entmakex
                (mapcar 'cons
                        '(0 10 11 1 8 7 62 40 41 72 73 50)
                        (append (list "TEXT" (car argments)) argments)
                )
        )
)
(defun c:tt (/ ss i a)
        (if (setq ss (SstoEs (ssget '((0 . "*polyline")
                                                                                                                                 (90 . 4)
                                                                                                                                 (-4 . "<OR")
                                                                                                                                 (70 . 1)
                                                                                                                                 (70 . 129)
                                                                                                                                 (-4 . "OR>")
                                                                                                                         )
                                                                                         )
                                                         )
                        )
                (foreach x (subtotals
                                                                 (vl-remove 'nil (mapcar 'ABcOfRectangle ss))
                                                                 1
                                                                 0
                                                         );;(((宽 高)(中心点 中心点 ...))((宽 高)(中心点 中心点 ...))((宽 高)(中心点 中心点 ...)))
                        (setq i 0
                                a (strcat (rtos (caar x)) "X" (rtos (cadar x)))
                        )
                        (foreach y (cdr x)
                                (maketxt
                                        (list y (strcat a "-" (itoa (setq i (1+ i)))) 1 1.5 1.0 1 2)
                                )
                        )
                )
        )
)

蓝盾设计

llsheng_73 发表于 2015-3-3 17:04
凑热闹

可以相同规格尺寸，编号归类标同一个编号就好了，

yoyoho

下载学了!!!!!谢谢分享!!!!

ll_j

没精力仔细看程序了，你用entmake构建文字，文字对中，就增加72组码（=4）就可以了。
第二个问题稍复杂，可能要重新构建程序框架，因为涉及比较，所以要“遍历”，建议你不要一个一个地处理，应该把所有实体的主要（需要用到的）元素构成一个普通表，然后根据需要对这个表进行“合并”、“除重”，最后再输出需要的内容。具体如实体表转普通表、除重等，论坛都有讨论，你可以搜索一下。

香田里浪人

对于怎样让相同高和宽的矩形编号一致，论坛里有选择相同线程序，转载如下，可供参考
;;;****择相同线 程序开始*****
(defun c:xtx ()
  (setvar "blipmode" 0)
  (setvar "pickfirst" 1)
  (setvar "expert" 0)  ;禁止显示提示“准备重生成 -- 继续进行?”和“是否确实要关闭当前图层?”
  (setvar "GRIPOBJLIMIT" 50) ;抑制当初始选择集包含的对象超过特定的数量时夹点的显示
  (setvar "osmode" 15359)
  (setvar "qaflags" 0)  
  (setvar "attmode" 2)
  (setvar "attreq" 1)
  (setvar "cmdecho" 0)
;以上的参数不知道是哪一个会影响到pselect的命令的有效性，有兴趣的可以试一下。

  (princ
    "\n★功能：挑选出与源曲线相同的多段线、直线、样条曲线、圆、圆弧.\n"
  )
  (prompt
    "\n★提示：如果所选对象中包含零长度的线段，则会出现错误。\n请先用“查找短线”功能处理零长度的线段。\n"
  )
  (vl-load-com)
  (command "undo" "be")
  (while
    (progn (setq ent1 (entsel "\n请选择曲线："))
           (not        (if (= ent1 nil)
                  nil
                  (wcmatch (cdr (assoc 0 (entget (car ent1))))
                           "LWPOLYLINE,POLYLINE,LINE,SPLINE,CIRCLE,ARC"
                  )
                                        ;限定只能选多段线、直线、样条曲线、圆、圆弧
                )
           )
    )
  )
  (setq entnam1 (car ent1))
  (setq linetype1 (cdr (assoc 0 (entget entnam1))))
  (setq obj1 (vlax-ename->vla-object entnam1))
  (setq        len1 (atof (rtos (vlax-curve-getdistatparam
                           obj1
                           (vlax-curve-getendparam obj1)
                         )
                         2
                         4
                   )
             )
  )
  (setq area1 (atof (rtos (vlax-curve-getarea obj1) 2 4)))
  (princ "\n请选择曲线对象：\n")
  (setq ss (ssget (list (cons 0 linetype1))))
  (if (not ss)
    (exit)
  )
  (setvar "osmode" 0)
  (setq        i   0
        lis (ssadd)                        ;设置选择集为空
  )
  (command "color" "Bylayer")
  (command "LAYER" "M" "相同线层" "C" "1" "相同线层" "")
  (repeat (sslength ss)
    (setq entnam2 (ssname ss i))
    (setq obj2 (vlax-ename->vla-object entnam2))
    (setq len2 (atof (rtos (vlax-curve-getdistatparam
                             obj2
                             (vlax-curve-getendparam obj2)
                           )
                           2
                           4
                     )
               )
    )
    (setq area2 (atof (rtos (vlax-curve-getarea obj2) 2 4)))
    (if        (and (= len1 len2) (= area1 area2))
      (progn
        (setq entdat (entget entnam2))
        (entmod
          (subst (cons 8 "相同线层") (assoc 8 entdat) entdat)
        )
        (ssadd entnam2 lis)                ;将相同线添加到选择集
      )
    )
    (setq i (1+ i))
  )
  (setvar "osmode" 15359)
  (princ "★提示：与源曲线相同的曲线已置于“相同线层”！")
  (command "undo" "e")
  (command "_.PSELECT" lis "")                ;选中相同线
  (princ)
)
;;;****择相同线 程序结束*****

edata

1. (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc))

(setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc))

1. (entmake (list '(0 . "TEXT") (cons 72 1)(cons 73 2)(cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))

(entmake (list '(0 . "TEXT") (cons 72 1)(cons 73 2)(cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))

edata

1. (defun c:tt(/ AREA E ENT H HH I II LST P1 PA PA1 PA2 PB PB1 PB2 PC PC1 PC2 PCEN PD PD1 PD2 RECS TEXTH W WW WXH X Y)
   
2.         (vl-load-com)
   
3.         (setq texth 200)
   
4.         (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))
   
5.           (repeat (setq i (sslength recs))
   
6.             (setq ent (entget (ssname recs (setq i (1- i))))
   
7.                   lst '()
   
8.                   e (cdr(car ent))
   
9.                   area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))
   
10.                   )
    
11.             (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内
    
12.             (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd
    
13.             (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标
    
14.             (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc));取得中矩形点
    
15.             (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点
    
16.             (if (and (equal (distance pa pc)(distance pb pd) 1e-8);判断是否为矩形
    
17.                      (or(equal  p1 pa 1e-8)
    
18.                         (equal  p1 pb 1e-8)
    
19.                         (equal  p1 pc 1e-8)
    
20.                         (equal  p1 pd 1e-8)
    
21.                         )
    
22.                      )
    
23.               (progn
    
24.                 (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度
    
25.                       h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度
    
26.                 (setq ww (rtos w 2 0))
    
27.                 (setq hh (rtos h 2 0))
    
28.                 (setq ii (rtos i 2 0))
    
29.                 (setq wxh (strcat ww "*" hh "-" ii))
    
30.                 (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))
    
31.                 )
    
32.               (print "非矩形")
    
33.               )
    
34.             )
    
35.           )
    
36.   (princ)
    
37.   )

(defun c:tt(/ AREA E ENT H HH I II LST P1 PA PA1 PA2 PB PB1 PB2 PC PC1 PC2 PCEN PD PD1 PD2 RECS TEXTH W WW WXH X Y)<br />         (vl-load-com)<br />         (setq texth 200)<br />         (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))<br />           (repeat (setq i (sslength recs))<br />             (setq ent (entget (ssname recs (setq i (1- i))))<br />                   lst '()<br />                   e (cdr(car ent))<br />                   area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))<br />                   )<br />             (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内<br />             (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd<br />             (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标<br />             (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc));取得中矩形点<br />             (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点<br />             (if (and (equal (distance pa pc)(distance pb pd) 1e-8);判断是否为矩形<br />                      (or(equal  p1 pa 1e-8)<br />                         (equal  p1 pb 1e-8)<br />                         (equal  p1 pc 1e-8)<br />                         (equal  p1 pd 1e-8)<br />                         )<br />                      )<br />               (progn<br />                 (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度<br />                       h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度<br />                 (setq ww (rtos w 2 0))<br />                 (setq hh (rtos h 2 0))<br />                 (setq ii (rtos i 2 0))<br />                 (setq wxh (strcat ww "*" hh "-" ii))<br />                 (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))<br />                 )<br />               (print "非矩形")<br />               )<br />             )<br />           )<br />   (princ)<br />   )

统计论坛有很多自己翻翻帖子。

那个猎人

edata 发表于 2014-5-12 23:25
统计论坛有很多自己翻翻帖子。

感谢大神帮把程序修改的这么精简，不过其中有个小失误，(equal (distance pa pc)(distance pb pd) 1e-8)这句话通过对角线是否相等来判断是否为矩形，条件不充分，因为等腰梯形的对角线也相等。所以应该加上对边相等这个条件，嘿嘿

edata

1. (defun c:tt(/ AREA E ENT H HH I II LST P1 PA PA1 PA2 PB PB1 PB2 PC PC1 PC2 PCEN pcen2 PD PD1 PD2 RECS TEXTH W WW WXH X Y)
   
2.         (vl-load-com)
   
3.         (setq texth 200)
   
4.         (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))
   
5.           (repeat (setq i (sslength recs))
   
6.             (setq ent (entget (ssname recs (setq i (1- i))))
   
7.                   lst '()
   
8.                   e (cdr(car ent))
   
9.                   area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))
   
10.                   )
    
11.             (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内
    
12.             (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd
    
13.             (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标
    
14.             (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc)
    
15.                   pcen2(mapcar '(lambda(x y)(*(+ x y) 0.5)) pb pd));取得中矩形点
    
16.             (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点
    
17.             (if (and (equal (distance pa pc)(distance pb pd) 1e-8);判断是否为矩形
    
18.                      (or(equal  p1 pa 1e-8)
    
19.                         (equal  p1 pb 1e-8)
    
20.                         (equal  p1 pc 1e-8)
    
21.                         (equal  p1 pd 1e-8)
    
22.                         )
    
23.                      (equal  pcen pcen2 1e-8)
    
24.                      )
    
25.               (progn
    
26.                 (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度
    
27.                       h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度
    
28.                 (setq ww (rtos w 2 0))
    
29.                 (setq hh (rtos h 2 0))
    
30.                 (setq ii (rtos i 2 0))
    
31.                 (setq wxh (strcat ww "*" hh "-" ii))
    
32.                 (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))
    
33.                 )
    
34.               (print "非矩形")
    
35.               )
    
36.             )
    
37.           )
    
38.   (princ)
    
39.   )

(defun c:tt(/ AREA E ENT H HH I II LST P1 PA PA1 PA2 PB PB1 PB2 PC PC1 PC2 PCEN pcen2 PD PD1 PD2 RECS TEXTH W WW WXH X Y)<br />         (vl-load-com)<br />         (setq texth 200)<br />         (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))<br />           (repeat (setq i (sslength recs))<br />             (setq ent (entget (ssname recs (setq i (1- i))))<br />                   lst '()<br />                   e (cdr(car ent))<br />                   area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))<br />                   )<br />             (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内<br />             (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd<br />             (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标<br />             (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc)<br />                   pcen2(mapcar '(lambda(x y)(*(+ x y) 0.5)) pb pd));取得中矩形点<br />             (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点<br />             (if (and (equal (distance pa pc)(distance pb pd) 1e-8);判断是否为矩形<br />                      (or(equal  p1 pa 1e-8)<br />                         (equal  p1 pb 1e-8)<br />                         (equal  p1 pc 1e-8)<br />                         (equal  p1 pd 1e-8)<br />                         )<br />                      (equal  pcen pcen2 1e-8)<br />                      )<br />               (progn<br />                 (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度<br />                       h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度<br />                 (setq ww (rtos w 2 0))<br />                 (setq hh (rtos h 2 0))<br />                 (setq ii (rtos i 2 0))<br />                 (setq wxh (strcat ww "*" hh "-" ii))<br />                 (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))<br />                 )<br />               (print "非矩形")<br />               )<br />             )<br />           )<br />   (princ)<br />   )

fan_zh

学习了，最好再考虑一种情况，如矩形有旋转也能用就好了

那个猎人

ll_j 发表于 2014-5-12 16:49
没精力仔细看程序了，你用entmake构建文字，文字对中，就增加72组码（=4）就可以了。
第二个问题稍复杂，可 ...

感谢大神提供的思路，按照这个思路我把程序这个程序基本完善了，就是前面的输入字高不能记忆，每次都是默认200高度。请各位大神批评指正。
(defun c:ttt(/ texth n b daihao m cenjihe wxhjihe recs i ent lst e area pa pb pc pd pa1 pa2 pb1 pb2 pc1 pc2 pd1 pd2 pcen x y p1 w h ww hh a bwh aa ii bianhao ptxt)
        (vl-load-com)
        (if (null texth)
                (setq texth 200))
                (if (setq n (getreal (strcat "\n请输入字高：<" (rtos texth) ">")))
                        (setq texth n)
             )
                 (if (null b)
                 (setq b 1))
                (if (setq n (getint (strcat "\n请输入起始编号：<" (rtos b) ">")))
                        (setq b n)
             )
                 (if (null daihao)
                 (setq daihao "GL"))
                (if (setq n (getstring (strcat "\n请输入代号前缀：<" daihao ">")))
                        (setq daihao n)
             )
                (setq cenjihe '())
                (setq wxhjihe '())
        (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))
                (progn
                (setq i (sslength recs))
          (repeat i
            (setq ent (entget (ssname recs (setq i (1- i))))
                  lst '()
                                  e (cdr(car ent))
                  area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))
                  )
            (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内
            (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd
            (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标
            (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc));取得中矩形点
            (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点
            (if (and (equal (distance pa pc)(distance pb pd) 1e-8) (equal (distance pa pb)(distance pc pd) 1e-8) (equal (distance pa pd)(distance pb pc) 1e-8);判断是否为矩形
                     (or(equal  p1 pa 1e-8)
                        (equal  p1 pb 1e-8)
                        (equal  p1 pc 1e-8)
                        (equal  p1 pd 1e-8)
                        )
                     )
              (progn
                (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度
                      h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度
                                (setq ww (rtos w 2 0))
                (setq hh (rtos h 2 0))
                                (setq cenjihe (cons pcen cenjihe))
                                (setq wxhjihe (cons (list ww hh) wxhjihe))
                )
              (print "非矩形")
              )
            )
                        )
                        )
    (setq i (sslength recs))
        (setq a 0)
        (repeat i
           (if (= (vl-list-length (nth a wxhjihe)) 2)
             (progn
             (setq bwh (cons b (nth a wxhjihe)))
             (setq wxhjihe (subst bwh (nth a wxhjihe) wxhjihe))
             (setq a (+ 1 a))
             (setq b (+ 1 b))
             )
                 (setq a (+ 1 a))
           )
         )
         (print wxhjihe)
         (setq aa 0)
         (repeat i
           (setq ii (rtos (car (nth aa wxhjihe)) 2 0))
           (setq bianhao (strcat (cadr (nth aa wxhjihe)) "*" (caddr (nth aa wxhjihe)) "-" daihao ii))
           (setq ptxt (nth aa cenjihe))
           (setq aa (+ 1 aa))
           (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 bianhao) (cons 10 ptxt)(cons 11 ptxt) (cons 40 texth)))
         )
  (princ)
  )

1. 
   

复制代码

edata

(setq i (sslength recs))开始的代码要放在判断是否是矩形  (progn内。)

1. (defun c:ttt(/ texth n b daihao m cenjihe wxhjihe recs i ent lst e area pa pb pc pd pa1 pa2 pb1 pb2 pc1 pc2 pd1 pd2 pcen x y p1 w h ww hh a bwh aa ii bianhao ptxt)
   
2.         (vl-load-com)
   
3.         (if (null texth)
   
4.                 (setq texth 200))
   
5.                 (if (setq n (getreal (strcat "\n请输入字高：<" (rtos texth) ">")))
   
6.                         (setq texth n)
   
7.              )
   
8.                  (if (null b)
   
9.                  (setq b 1))
   
10.                 (if (setq n (getint (strcat "\n请输入起始编号：<" (rtos b) ">")))
    
11.                         (setq b n)
    
12.              )
    
13.                  (if (null daihao)
    
14.                  (setq daihao "GL"))
    
15.                 (if (setq n (getstring (strcat "\n请输入代号前缀：<" daihao ">")))
    
16.                         (setq daihao n)
    
17.              )
    
18.                 (setq cenjihe '())
    
19.                 (setq wxhjihe '())
    
20.         (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))
    
21.                 (progn
    
22.                 (setq i (sslength recs))
    
23.           (repeat i
    
24.             (setq ent (entget (ssname recs (setq i (1- i))))
    
25.                   lst '()
    
26.                                   e (cdr(car ent))
    
27.                   area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))
    
28.                   )
    
29.             (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内
    
30.             (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd
    
31.             (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标
    
32.             (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc));取得中矩形点
    
33.             (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点
    
34.             (if (and (equal (distance pa pc)(distance pb pd) 1e-8) (equal (distance pa pb)(distance pc pd) 1e-8) (equal (distance pa pd)(distance pb pc) 1e-8);判断是否为矩形
    
35.                      (or(equal  p1 pa 1e-8)
    
36.                         (equal  p1 pb 1e-8)
    
37.                         (equal  p1 pc 1e-8)
    
38.                         (equal  p1 pd 1e-8)
    
39.                         )
    
40.                      )
    
41.               (progn
    
42.                 (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度
    
43.                       h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度
    
44.                                 (setq ww (rtos w 2 0))
    
45.                 (setq hh (rtos h 2 0))
    
46.                                 (setq cenjihe (cons pcen cenjihe))
    
47.                                 (setq wxhjihe (cons (list ww hh) wxhjihe))
    
48.                 (setq i (sslength recs))
    
49.         (setq a 0)
    
50.         (repeat i
    
51.            (if (= (vl-list-length (nth a wxhjihe)) 2)
    
52.              (progn
    
53.              (setq bwh (cons b (nth a wxhjihe)))
    
54.              (setq wxhjihe (subst bwh (nth a wxhjihe) wxhjihe))
    
55.              (setq a (+ 1 a))
    
56.              (setq b (+ 1 b))
    
57.              )
    
58.                  (setq a (+ 1 a))
    
59.            )
    
60.          )
    
61.          (print wxhjihe)
    
62.          (setq aa 0)
    
63.          (repeat i
    
64.            (setq ii (rtos (car (nth aa wxhjihe)) 2 0))
    
65.            (setq bianhao (strcat (cadr (nth aa wxhjihe)) "*" (caddr (nth aa wxhjihe)) "-" daihao ii))
    
66.            (setq ptxt (nth aa cenjihe))
    
67.            (setq aa (+ 1 aa))
    
68.            (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 bianhao) (cons 10 ptxt)(cons 11 ptxt) (cons 40 texth)))
    
69.          )
    
70.                 )
    
71.               (print "非矩形")
    
72.               )
    
73.             )
    
74.                         )
    
75.                         )
    
76.    
    
77.   (princ)
    
78.   )

(defun c:ttt(/ texth n b daihao m cenjihe wxhjihe recs i ent lst e area pa pb pc pd pa1 pa2 pb1 pb2 pc1 pc2 pd1 pd2 pcen x y p1 w h ww hh a bwh aa ii bianhao ptxt)<br />         (vl-load-com)<br />         (if (null texth)<br />                 (setq texth 200))<br />                 (if (setq n (getreal (strcat "\n请输入字高：<" (rtos texth) ">")))<br />                         (setq texth n)<br />              )<br />                  (if (null b)<br />                  (setq b 1))<br />                 (if (setq n (getint (strcat "\n请输入起始编号：<" (rtos b) ">")))<br />                         (setq b n)<br />              )<br />                  (if (null daihao)<br />                  (setq daihao "GL"))<br />                 (if (setq n (getstring (strcat "\n请输入代号前缀：<" daihao ">")))<br />                         (setq daihao n)<br />              )<br />                 (setq cenjihe '())<br />                 (setq wxhjihe '())<br />         (if(setq recs (ssget '((0 . "LWPOLYLINE")(90 . 4))))<br />                 (progn<br />                 (setq i (sslength recs))<br />           (repeat i<br />             (setq ent (entget (ssname recs (setq i (1- i))))<br />                   lst '()<br />                                   e (cdr(car ent))<br />                   area (vlax-curve-getArea (Vlax-Ename->Vla-Object e))<br />                   )<br />             (foreach n ent (if (= (car n) 10)(setq lst (cons (cdr n) lst))));遍历边界组合，将顶点存入lst内<br />             (setq pa (car lst) pb (cadr lst) pc (caddr lst) pd (cadddr lst));四个顶点坐标分别为pa,pb,pc,pd<br />             (setq pa1 (car pa) pa2 (cadr pa) pb1 (car pb) pb2 (cadr pb) pc1 (car pc) pc2 (cadr pc) pd1 (car pd) pd2 (cadr pd));顶点坐标值横竖坐标<br />             (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc));取得中矩形点<br />             (setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点<br />             (if (and (equal (distance pa pc)(distance pb pd) 1e-8) (equal (distance pa pb)(distance pc pd) 1e-8) (equal (distance pa pd)(distance pb pc) 1e-8);判断是否为矩形<br />                      (or(equal  p1 pa 1e-8)<br />                         (equal  p1 pb 1e-8)<br />                         (equal  p1 pc 1e-8)<br />                         (equal  p1 pd 1e-8)<br />                         )<br />                      )<br />               (progn<br />                 (setq w(- (max pa1 pb1 pc1 pd1)(min pa1 pb1 pc1 pd1));计算宽度<br />                       h(- (max pa2 pb2 pc2 pd2)(min pa2 pb2 pc2 pd2)));计算高度<br />                                 (setq ww (rtos w 2 0))<br />                 (setq hh (rtos h 2 0))<br />                                 (setq cenjihe (cons pcen cenjihe))<br />                                 (setq wxhjihe (cons (list ww hh) wxhjihe))<br />                 (setq i (sslength recs))<br />         (setq a 0)<br />         (repeat i<br />            (if (= (vl-list-length (nth a wxhjihe)) 2)<br />              (progn<br />              (setq bwh (cons b (nth a wxhjihe)))<br />              (setq wxhjihe (subst bwh (nth a wxhjihe) wxhjihe))<br />              (setq a (+ 1 a))<br />              (setq b (+ 1 b))<br />              )<br />                  (setq a (+ 1 a))<br />            )<br />          )<br />          (print wxhjihe)<br />          (setq aa 0)<br />          (repeat i<br />            (setq ii (rtos (car (nth aa wxhjihe)) 2 0))<br />            (setq bianhao (strcat (cadr (nth aa wxhjihe)) "*" (caddr (nth aa wxhjihe)) "-" daihao ii))<br />            (setq ptxt (nth aa cenjihe))<br />            (setq aa (+ 1 aa))<br />            (entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 bianhao) (cons 10 ptxt)(cons 11 ptxt) (cons 40 texth)))<br />          )<br />                 )<br />               (print "非矩形")<br />               )<br />             )<br />                         )<br />                         )<br />     <br />   (princ)<br />   )