《悬赏3明经币》求“搜索多边形内的线”的程序
本帖最后由 chenjian2159 于 2011-4-13 14:52 编辑根据白色的多边形自动搜索里面红色的线，返回搜索到线的选择集，白色多边形里面可能有多条线，谢谢朋友们参与！！！ 本帖最后由 gufeng 于 2011-6-23 13:52 编辑
有时间弄了下下
;_搜索多边形内的线 TT
;_计算面积 TT1
(defun c:TT (/ ENAME NEWENTLAST OLDENTLAST PT I PLIST EN OCMDECHO)
(while (setq ename (car (entsel "\n选择多边形:")))
(AT_Li:20110623)
(if$SS
(progn
(setq i -1)
(while (setq en (ssname $SS (setq i (1+ i))))
(redraw en 4)
)
)
) ;_恢复原选择集的亮度
(redraw ename 3)
(setq pt (AT_L:GetPlInPt (AT_S:GetEnameBox ename))) ;_得到多边形内一点
(setq ocmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(command "_undo" "mark")
(setq oldentlast (entlast)) ;_最后的图元名
(command "-boundary" "a" "b" "n" ename "" "" pt "")
(setq newentlast (entlast)) ;_Boundary后
(if(eq oldentlast newentlast)
(progn
(setq $SS nil)
(princ "\n\t生成边界错误,搜索退出")
)
(progn
(setq plist (AT_L:Plist newentlast))
(if (> (length plist) 2)
(progn
(command "_zoom"
(car (AT_S:GetEnameBox ename))
(cadr (AT_S:GetEnameBox ename))
)
(setq $SS (ssget "wp" plist '((0 . "LWPOLYLINE"))))
)
(princ "\n\t坐标少于两个,搜索退出")
)
)
)
(command "_undo" "back")
(setvar "cmdecho" ocmdecho)
(redraw ename 4)
(if$SS
(progn
(setq i -1)
(while (setq ename (ssname $SS (setq i (1+ i))))
(redraw ename 3)
)
(princ
(strcat "\n\t图元数量: " (itoa (sslength $SS)) " 已亮显")
)
)
)
)
(princ)
)
(defun c:TT1 (/ENAME ENAMELST ERR_5 IIISJXELST MJ MJ1MJ2 NEWENTLAST OCMDECHOOLDENTLAST PLIST PT SS SS_WP WP_ENAME WS JD)
(setq ws nil) ;_如果为t则先取位再加减反之则面积先加减最后取位
(setq jd 2) ;_面积小数位
(setq ss (ssget '((0 . "LWPOLYLINE"))))
(if ss
(progn
(AT_Li:20110623)
(setq enamelst (AT_S:ToEnameMjLst ss)) ;_图元与面积表
(setq enamelst (AT_L:Sort_lst enamelst)) ;_按面积从大到小排序
(setq mj 0) ;_总面积
(setq err_5 '()) ;_记录无法计算的图元句柄列表
(setq isjxelst '()) ;_已经计算过面积的图元列表
(setq ocmdecho (getvar "cmdecho"))
(setvar "cmdecho" 0)
(foreach i enamelst
(setq ename (last i)) ;_图元名
(if (not (member ename isjxelst))
(progn
(setq pt (AT_L:GetPlInPt (AT_S:GetEnameBox ename))) ;_多边形内一点
(command "_undo" "mark")
(setq oldentlast (entlast)) ;_最后的图元名
(command "-boundary" "a" "b" "n" ename "" "" pt "")
(setq newentlast (entlast)) ;_Boundary后
(if(eq oldentlast newentlast)
(progn
(setq err_5 (cons (cdr (assoc 5 (entget ename))) err_5)) ;_错误
)
(progn
(setq mj1 (vlax-curve-getArea newentlast)) ;_重新计算面积
(if ws
(setq mj1 (AT_G:SsWr mj1 jd))
)
(setq plist (AT_L:Plist newentlast))
(if (> (length plist) 2)
(progn
(command "_zoom"
(car (AT_S:GetEnameBox ename))
(cadr (AT_S:GetEnameBox ename))
)
(setq ss_wp (ssget "wp" plist '((0 . "LWPOLYLINE"))))
(ifss_wp
(progn
(setq ii -1)
(while (setq wp_ename (ssname ss_wp (setq ii (1+ ii))))
(setq isjxelst (cons wp_ename isjxelst))
;_计算内多边形面积 Start
(setq pt (AT_L:GetPlInPt (AT_S:GetEnameBox wp_ename)))
(command "_undo" "mark")
(setq newentlast (entlast))
(command "-boundary" "a" "b" "n" ename "" "" pt "")
(setq oldentlast (entlast))
(if (eq oldentlast newentlast)
(setq mj2 (vlax-curve-getArea wp_ename)) ;_Boundary无法生成直接使用线面积
(setq mj2 (vlax-curve-getArea newentlast)) ;_使用Boundary生成的线面积
)
(if ws
(setq mj2 (AT_G:SsWr mj2 jd))
)
(command "_undo" "back")
;_计算内多边形面积 End
(setq mj1 (- mj1 (vlax-curve-getArea wp_ename)))
)
)
)
(setq mj (+ mj mj1)) ;_加入到总面积
)
(setq err_5 (cons (cdr (assoc 5 (entget ename))) err_5)) ;_错误
)
)
)
(command "_undo" "back")
)
)
)
(setvar "cmdecho" ocmdecho)
(princ (strcat "\n总面积是: " (rtos mj 2 jd)))
(if err_5
(progn
(princ "\n无法计算的图元句柄表:")
(princ err_5)
)
)
)
(princ "\n没有选择计算的对象")
)
(princ)
)
;_使用到的相关函数
(defun AT_Li:20110623 ()
(vl-load-com)
;_四舍五入 (AT_G:SsWr NUM JD)
(defun AT_G:SsWr (NUM JD / RETURN)
(read (rtos num 2 jd))
)
;_返回多段线的坐标表 (AT_L:Plist ENAME)
(defun AT_L:Plist (ENAME / ELEV EN ENTL FLAG PT VLIST)
(defun LI_item (n alist)
(cdr (assoc n alist))
)
(setq
vlist '()
entl(entget ename)
en (LI_item 0 entl)
)
(cond
((= en "LWPOLYLINE")
(setq
vlist '()
Elev(LI_item 38 entl)
)
(foreachpt entl
(if (= (car pt) 10)
(setq vlist (cons (list (cadr pt) (caddr pt) Elev) vlist))
)
)
(setq vlist (reverse vlist))
)
((= en "SPLINE")
(setq vlist (LI_mitem 11 entl))
(if (not vlist)
(setq vlist (LI_mitem 10 entl))
(setq vlist (reverse (reverse vlist)))
)
)
((= en "POLYLINE")
(setq
ename (entnext ename)
entl(entget ename)
en (LI_item 0 entl)
vlist '()
)
(while (= en "VERTEX")
(setq flag (LI_item 70 entl))
(if (and
(zerop (logand flag 1))
(zerop (logand flag 2))
(zerop (logand flag 8))
(/= flag 128)
)
(setq
pt (LI_item 10 entl)
vlist (cons pt vlist)
)
)
(setq
ename (entnext ename)
entl (entget ename)
en (LI_item 0 entl)
)
)
(setq vlist (reverse vlist))
)
((= en "LINE")
(setq vlist (list (LI_item 10 entl) (LI_item 11 entl)))
)
((= en "3DFACE")
(setq vlist (list
(LI_item 10 entl)
(LI_item 11 entl)
(LI_item 12 entl)
(LI_item 13 entl)
)
)
)
)
vlist
)
;_获得 单个图元 的最大包围框 (AT_S:GetEnameBox ENAME)
(defun AT_S:GetEnameBox (ENAME / OBJ MINPOINT MAXPOINT)
(setq obj (vlax-ename->vla-object ename))
(vla-GetBoundingBox obj 'minpoint 'maxpoint) ;_取得包容图元的最大点和最小点
(setq minpoint (vlax-safearray->list minpoint)) ;_把变体数据转化为表
(setq maxpoint (vlax-safearray->list maxpoint)) ;_把变体数据转化为表
(setq obj (list minpoint maxpoint))
)
;_获取多边形内一点 部分适用 (AT_L:GetPlInPt PLIST)
(defun AT_L:GetPlInPt(PLIST / P1 P2 PT)
(setq p1 (car plist)
p2 (cadr plist)
)
(setq p1 (list (car p1) (cadr p1))
p2 (list (car p2) (cadr p2))
)
(setq pt (polar p1 (angle p1 p2) (/ (distance p1 p2) 2)))
pt
)
;_由选择集返回图元与面积表 (AT_S:ToEnameMjLst SS)
(defun AT_S:ToEnameMjLst (SS / I E LST MJ)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq mj (vlax-curve-getArea e))
(setq lst (cons (list mj e) lst))
)
(reverse lst)
)
;_由选择集返回图元表 (AT_S:ToEnameLst SS)
(defun AT_S:ToEnameLst (SS / I E LST)
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(setq lst (cons e lst))
)
(reverse lst)
)
;_表排序 (AT_L:Sort_lst LST)
(defun AT_L:Sort_lst (LST)
(vl-sort lst
(function (lambda (e1 e2)
(> (car e1) (car e2))
)
)
)
)
)
如何取得 '白色的多边形'只白色?
里面的一定是红色的线?
图面可还存在其他图元会影响自动搜索
单以所附文件是很容易处理,
须考量的在此之外的可能情况.... 回复 Andyhon 的帖子
你好朋友，我说的“白色的多边形和红色的多边形”是自己改的，是想表达的清楚点，实际上工作中，颜色是没有分出来的，都是同一种颜色。谢谢你！ ....
须考量的在此之外的可能情况....
可否上传数个具代表性的图样 (*.Dwg)
还是说就这么单纯而已 顶！！！！ 回复 Andyhon 的帖子
朋友，已经上传图样，谢谢！ 这个不合 AutoCAD 求面积的规范
未曾涉及过相仿于所提样图的程序 ....
或许第三方插有这样的程序
VLX格式的算么？
没有源码的可以么？
页:
[1]
2