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

llsheng_73

1. (defun SstoEs(ss / a en lst)
   
2.   (if ss(repeat(setq a(sslength ss))
   
3.          (setq a(1- a)lst(cons(ssname ss a)lst))))
   
4.   lst)
   
5. (defun plinexy(e / p i)
   
6.   (setq i -1)
   
7.   (mapcar(function(lambda(x)(list(car x)(cadr x))))(reverse(repeat(fix(1+(vlax-curve-getEndParam e)))
   
8.     (setq i(1+ i)p(cons(vlax-curve-getPointAtParam e i)p)))))
   
9.   (if(equal(car p)(last p))(reverse(cdr(reverse p)))p)
   
10.   )
    
11. (defun ABCOfRectangle(e / pt a b);;矩形中心及长宽
    
12.   (if(and(=(length(setq pt(plinexy e)))4)
    
13.          (equal(setq a(distance(car pt)(cadr pt)))
    
14.                (distance(last pt)(caddr pt))1e-6)
    
15.          (equal(setq b(distance(cadr pt)(caddr pt)))
    
16.                (distance(last pt)(car pt))1e-6)
    
17.          (equal(distance(car pt)(caddr pt))
    
18.                (distance(last pt)(cadr pt))1e-6))
    
19.     (list(mapcar'(lambda(x)(* x 0.5))(mapcar'+(car pt)(caddr pt)))(vl-sort(mapcar'atof(mapcar'rtos(list a b)))'>))))
    
20. (defun subtotals(lst m ns / myfun a b c);;对lst以子表第m项为关键字进行分类,ns为整数时记录第ns项、为表(2 3)记录表中指定的项、为空或者其它记录关键字以外所有项
    
21.   (cond((=(type ns)'LIST)(defun myfun(x)(list(mapcar'(lambda(y)(nth y x))ns))))
    
22.        ((=(type ns)'INT)(defun myfun(x)(list(nth ns x))))
    
23.        (t(defun myfun(x)(list(vl-remove c x)))))
    
24.   (foreach x lst
    
25.     (setq a(if(setq c(nth m x)b(assoc c a))
    
26.        (subst(append b(myfun x))b a)
    
27.        (append a(list(append(list c)(myfun x))))))))
    
28. (defun maketxt(argments / InsOrDel);;argments pt txt la style color h hz jz z ro) txt后边的图层，字体可省
    
29.   (defun InsOrDel(lst pos mod / qlst a hlst);{在指定位置删除或插入元素mod为要插入的元素为空时删除第pos项}
    
30.     (setq a -1)
    
31.     (setq hlst(vl-member-if-not'(lambda(x)(setq a(1+ a))(if(= a pos) nil(setq qlst (cons x qlst))))lst))
    
32.     (if mod(apply 'append (list (reverse(cons mod qlst)) hlst))
    
33.       (apply 'append (list (reverse qlst)(cdr hlst)))))
    
34.   (setq argments(if(or(/=(type(nth 2 argments))'str)(null(tblsearch"layer"(nth 2 argments))))
    
35.                       (InsOrDel argments 2(getvar'clayer))argments)
    
36.         argments(if(or(/=(type(nth 3 argments))'str)(null(tblsearch"style"(nth 3 argments))))
    
37.                       (InsOrDel argments 3"Standard"))argments)
    
38. (entmakex(mapcar'cons'(0 10 11 1 8 7 62 40 41 72 73 50)(append(list"TEXT"(car argments))argments))))
    
39. (defun c:tt(/ ss i a)
    
40. (if(setq ss(SstoEs(ssget'((0 . "*polyline")(90 . 4)(-4 . "<OR") (70 . 1)(70 . 129)(-4 . "OR>")))))
    
41.    (foreach x(subtotals(vl-remove'nil(mapcar'ABcOfRectangle ss))1 0)
    
42.      (setq i 0 a(strcat(rtos(caar x))"X"(rtos(cadar x))))
    
43.      (foreach y(cdr x)
    
44.        (maketxt(list y(strcat a"-"(itoa(setq i(1+ i))))1 1.5 1.0 1 2)))))
    
45.   )

(defun SstoEs(ss / a en lst)<br />   (if ss(repeat(setq a(sslength ss))<br />          (setq a(1- a)lst(cons(ssname ss a)lst))))<br />   lst)<br /> (defun plinexy(e / p i)<br />   (setq i -1)<br />   (mapcar(function(lambda(x)(list(car x)(cadr x))))(reverse(repeat(fix(1+(vlax-curve-getEndParam e)))<br />     (setq i(1+ i)p(cons(vlax-curve-getPointAtParam e i)p)))))<br />   (if(equal(car p)(last p))(reverse(cdr(reverse p)))p)<br />   )<br /> (defun ABCOfRectangle(e / pt a b);;矩形中心及长宽<br />   (if(and(=(length(setq pt(plinexy e)))4)<br />          (equal(setq a(distance(car pt)(cadr pt)))<br />                (distance(last pt)(caddr pt))1e-6)<br />          (equal(setq b(distance(cadr pt)(caddr pt)))<br />                (distance(last pt)(car pt))1e-6)<br />          (equal(distance(car pt)(caddr pt))<br />                (distance(last pt)(cadr pt))1e-6))<br />     (list(mapcar'(lambda(x)(* x 0.5))(mapcar'+(car pt)(caddr pt)))(vl-sort(mapcar'atof(mapcar'rtos(list a b)))'>))))<br /> (defun subtotals(lst m ns / myfun a b c);;对lst以子表第m项为关键字进行分类,ns为整数时记录第ns项、为表(2 3)记录表中指定的项、为空或者其它记录关键字以外所有项<br />   (cond((=(type ns)'LIST)(defun myfun(x)(list(mapcar'(lambda(y)(nth y x))ns))))<br />        ((=(type ns)'INT)(defun myfun(x)(list(nth ns x))))<br />        (t(defun myfun(x)(list(vl-remove c x)))))<br />   (foreach x lst<br />     (setq a(if(setq c(nth m x)b(assoc c a))<br />        (subst(append b(myfun x))b a)<br />        (append a(list(append(list c)(myfun x))))))))<br /> (defun maketxt(argments / InsOrDel);;argments pt txt la style color h hz jz z ro) txt后边的图层，字体可省<br />   (defun InsOrDel(lst pos mod / qlst a hlst);{在指定位置删除或插入元素mod为要插入的元素为空时删除第pos项}<br />     (setq a -1)<br />     (setq hlst(vl-member-if-not'(lambda(x)(setq a(1+ a))(if(= a pos) nil(setq qlst (cons x qlst))))lst))<br />     (if mod(apply 'append (list (reverse(cons mod qlst)) hlst))<br />       (apply 'append (list (reverse qlst)(cdr hlst)))))<br />   (setq argments(if(or(/=(type(nth 2 argments))'str)(null(tblsearch"layer"(nth 2 argments))))<br />                       (InsOrDel argments 2(getvar'clayer))argments)<br />         argments(if(or(/=(type(nth 3 argments))'str)(null(tblsearch"style"(nth 3 argments))))<br />                       (InsOrDel argments 3"Standard"))argments)<br /> (entmakex(mapcar'cons'(0 10 11 1 8 7 62 40 41 72 73 50)(append(list"TEXT"(car argments))argments))))<br /> (defun c:tt(/ ss i a)<br /> (if(setq ss(SstoEs(ssget'((0 . "*polyline")(90 . 4)(-4 . "<OR") (70 . 1)(70 . 129)(-4 . "OR>")))))<br />    (foreach x(subtotals(vl-remove'nil(mapcar'ABcOfRectangle ss))1 0)<br />      (setq i 0 a(strcat(rtos(caar x))"X"(rtos(cadar x))))<br />      (foreach y(cdr x)<br />        (maketxt(list y(strcat a"-"(itoa(setq i(1+ i))))1 1.5 1.0 1 2))))) <br />   )

凑热闹

鱼与熊掌

都什么时候的帖子了 还挂着 未解决

LPACMQ

我只能观摩了

CAD小学徒

下载啦。。。。。。。。。。。。。。。。。。。。。

906460210

求一个自动编号闭合面的插件

wawbt

进来学习一下。

yoyoho

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

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
凑热闹

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