本帖最后由 llsheng_73 于 2015-3-3 17:57 编辑
(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)))
(distance(last pt)(caddr pt))1e-6)
(equal(setq b(distance(cadr pt)(caddr pt)))
(distance(last pt)(car pt))1e-6)
(equal(distance(car pt)(caddr pt))
(distance(last pt)(cadr pt))1e-6))
(list(mapcar'(lambda(x)(* x 0.5))(mapcar'+(car pt)(caddr pt)))(vl-sort(mapcar'atof(mapcar'rtos(list a b)))'>))))
(defun subtotals(lst m ns / myfun a b c);;对lst以子表第m项为关键字进行分类,ns为整数时记录第ns项、为表(2 3)记录表中指定的项、为空或者其它记录关键字以外所有项
(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))))))))
(defun maketxt(argments / InsOrDel);;argments pt txt la style color h hz jz z ro) txt后边的图层，字体可省
(defun InsOrDel(lst pos mod / qlst a hlst);{在指定位置删除或插入元素mod为要插入的元素为空时删除第pos项}
(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的回帖
;;选集转图元名列表
(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
凑热闹
可以相同规格尺寸，编号归类标同一个编号就好了，