求大神帮忙解决相同矩形编号问题
本人小菜鸟一只，因为板块提料问题，想自动生成矩形板的宽和高和编号，标注到板块中心处。现有两个问题不能解决，想请教诸位大神
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)
)
翻译下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
凑热闹
可以相同规格尺寸，编号归类标同一个编号就好了， 下载学了!!!!!谢谢分享!!!! 没精力仔细看程序了，你用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)
)
;;;****择相同线 程序结束***** (setq pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc))
(entmake (list '(0 . "TEXT") (cons 72 1)(cons 73 2)(cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth))) (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)
(vl-load-com)
(setq texth 200)
(if(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 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);判断是否为矩形
(or(equalp1 pa 1e-8)
(equalp1 pb 1e-8)
(equalp1 pc 1e-8)
(equalp1 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 ii (rtos i 2 0))
(setq wxh (strcat ww "*" hh "-" ii))
(entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))
)
(print "非矩形")
)
)
)
(princ)
)
统计论坛有很多自己翻翻帖子。 edata 发表于 2014-5-12 23:25 static/image/common/back.gif
统计论坛有很多自己翻翻帖子。
感谢大神帮把程序修改的这么精简，不过其中有个小失误，(equal (distance pa pc)(distance pb pd) 1e-8)这句话通过对角线是否相等来判断是否为矩形，条件不充分，因为等腰梯形的对角线也相等。所以应该加上对边相等这个条件，嘿嘿 (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)
(vl-load-com)
(setq texth 200)
(if(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 pcen(mapcar '(lambda(x y)(*(+ x y) 0.5)) pa pc)
pcen2(mapcar '(lambda(x y)(*(+ x y) 0.5)) pb pd));取得中矩形点
(setq p1(list (min pa1 pb1 pc1 pd1)(min pa2 pb2 pc2 pd2)));取得左下角点
(if (and (equal (distance pa pc)(distance pb pd) 1e-8);判断是否为矩形
(or(equalp1 pa 1e-8)
(equalp1 pb 1e-8)
(equalp1 pc 1e-8)
(equalp1 pd 1e-8)
)
(equalpcen pcen2 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 ii (rtos i 2 0))
(setq wxh (strcat ww "*" hh "-" ii))
(entmake (list '(0 . "TEXT")(cons 72 1)(cons 73 2) (cons 1 wxh) (cons 10 pcen)(cons 11 pcen) (cons 40 texth)))
)
(print "非矩形")
)
)
)
(princ)
) 学习了，最好再考虑一种情况，如矩形有旋转也能用就好了 本帖最后由 那个猎人 于 2014-5-15 09:51 编辑
ll_j 发表于 2014-5-12 16:49 static/image/common/back.gif
没精力仔细看程序了，你用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(equalp1 pa 1e-8)
(equalp1 pb 1e-8)
(equalp1 pc 1e-8)
(equalp1 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)
)
(setq i (sslength recs))开始的代码要放在判断是否是矩形(progn内。)
(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(equalp1 pa 1e-8)
(equalp1 pb 1e-8)
(equalp1 pc 1e-8)
(equalp1 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))
(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)))
)
)
(print "非矩形")
)
)
)
)
(princ)
)