llsheng_73 发表于 2014-5-12 09:47 static/image/common/back.gif
我觉得可以求出所有图元的包容盒，设置一个容差值，对所有包容盒进行处理
如果两个包容盒相交或者包含或者 ...
我也觉得这种算法好一点，问题的归根结底就是算出那些实体是在同一个模糊范围内的，除了要求作图相对规范外，也无法提更高要求，当然，人为做块是一种方法，但耗时、耗力是肯定的，对于实体，求包围盒其实就是求最大最小坐标，速度差异是很小的，因此，我感觉你这个方法是合理的。
cxjzxh 发表于 2014-5-12 16:50 static/image/common/back.gif
具体描述为：
1.选择集a,第一个图元外框ssget（外框四点点集）
2.以选择到的图元作为一个新的外框；
这样的图会出现啥效果？
来个比较特殊的例子：
焊接演变：
本帖最后由 邹锋 于 2014-5-12 18:47 编辑
再来试试这些图
boundary 你们都是用这命令来的吗
邹锋 发表于 2014-5-12 18:36 static/image/common/back.gif
再来试试这些图
boundary 你们都是用这命令来的吗
程序:
;;框选物体画框 By Gu_xl 明经通道 2014.05.12
(defun c:mBox (/ BOX INTERSECT RECTANG SS N L A L1 FLAG B C)
(defun box (e / p1 p2 p3 p4 obj)
(setq obj (vlax-ename->vla-object e))
(vla-GetBoundingBox obj 'p1 'p3)
(setq p1 (vlax-safearray->list p1)
p3 (vlax-safearray->list p3)
p2 (list (car p1) (cadr p3) (caddr p1))
p4 (list (car p3) (cadr p1) (caddr p1))
)
(if(= "SPLINE" (cdr (assoc 0 (entget e))))
(progn
(SETQ lst
(mapcar '(lambda(a b)
(vlax-curve-getClosestPointToProjection e a b t)
)
(list p1 p2 p3 p4)
'((1.0 0 0) (0 -1.0 0) (-1.0 0 0) (0 1.0 0))
)
)
(list
(apply 'mapcar (cons 'min lst))
(apply 'mapcar (cons 'max lst))
)
)
(list p1 p3)
)
)
(defun intersect (a b)
(if
(or
(and
(<= (caar a) (caar b) (caadr a))
(<= (cadar a) (cadar b) (cadadr a))
)
(and
(<= (caar a) (caar b) (caadr a))
(<= (cadar a) (cadadr b) (cadadr a))
)
(and
(<= (caar a) (caadr b) (caadr a))
(<= (cadar a) (cadadr b) (cadadr a))
)
(and
(<= (caar a) (caadr b) (caadr a))
(<= (cadar a) (cadar b) (cadadr a))
)
)
(list
(apply 'mapcar (cons 'min (append a b)))
(apply 'mapcar (cons 'max (append a b)))
)
)
)
(defun rectang (a b)
(entmake
(list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(8 . "0")
'(62 . 1)
'(100 . "AcDbPolyline")
'(90 . 4)
'(70 . 1)
(cons 10 a)
(list 10 (car a) (cadr b))
(cons 10 b)
(list 10 (car b) (cadr a))
)
)
)
(if (setq ss (ssget))
(progn
(repeat (setq n (sslength ss))
(setq l (cons (box (ssname ss (setq n (1- n)))) l))
)
(setq l
(vl-sort
l
'(lambda(a b)
(if (equal (caar a) (caar b) 1e-3)
(if(equal (cadar a) (cadar b) 1e-3)
(if (equal (caadr a) (caadr b) 1e-3)
(< (cadadr a) (cadadr b))
(< (caadr a) (caadr b))
)
(< (cadar a) (cadar b))
)
(< (caar a) (caar b))
)
)
)
)
(setq a (car l)
l (cdr l)
)
(while l
(setq l1 nil
flag nil
)
(while l
(setqb (car l)
l (cdr l)
)
(if (setq c (intersect a b))
(setq a c
flag t
)
(setq l1 (cons b l1))
)
)
(setq l (reverse l1))
(if (not flag)
(progn
(rectang (car a) (cadr a))
(setq a (car l)
l (cdr l)
)
)
)
(if (not l)
(rectang (car a) (cadr a))
)
)
)
)
(princ)
)
本帖最后由 langjs 于 2014-5-12 21:20 编辑
测试图纸没通过
(defun c:qqq ( / i lst lst1 lst2 lst3 n nn nnn ss)
(setq lst '() lst1 '() lst3 '())
(setq ss (ssget '((0 . "LINE"))))
(repeat (setq i (sslength ss))
(setq lst (cons (ssname ss (setq i (1- i))) lst))
)
(while (setq n (car lst))
(setq lst (vl-remove n lst) lst2 (list n)lst3 (cons n lst3))
(foreach nn lst
(if (inters (cdr (assoc 10 (entget n)))(cdr (assoc 11 (entget n)))
(cdr (assoc 10 (entget nn))) (cdr (assoc 11 (entget nn))))
(setq lst2 (cons nn lst2))
)
)
(setq lst1 (cons lst2 lst1))
)
(while (setq n (car lst3))
(setq lst2 '())
(foreach nn lst1
(if (member n nn)
(setq lst2 (append lst2nn ))
)
(foreach nnn lst2
(setq lst2 (cons nnn (vl-remove nnn lst2)))
)
)
(foreach nn lst2
(setq lst3 (vl-remove nn lst3))
)
(setq lst (cons lst2 lst))
)
)
cxjzxh 发表于 2014-5-12 16:50 static/image/common/back.gif
具体描述为：
1.选择集a,第一个图元外框ssget（外框四点点集）
2.以选择到的图元作为一个新的外框；
这个思路很好哈