Gu_xl 发表于 2014-5-12 20:05 static/image/common/back.gif
程序:
谢谢固版的源码！我还没有研究过你的源码，只是测试了一下有个小漏洞！那两个圆是不是应该为单独的一个最小包围框才对呢？
找时间仔细看看学习！
谢谢固版的源码！
我也好想知道原理啊，应该不是对每个图元都进行框选再进行逻辑运算吧，要30帖才能看大神的程序
非常不错，学习了
本帖最后由 革天明 于 2015-2-21 14:51 编辑
Gu_xl 发表于 2014-5-12 20:05 static/image/common/back.gif
程序:
如果只选择一个图元，则程序不运行，修改了一下，对于单个图元也可以运行
;;框选物体画框 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))
)
)
)
;;(setq l '())
(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);;(if(not(cdr l))(car l)(cdr l))
)
(if (not l)
(rectang (car a) (cadr a))
(while l
(setq l1 nil
flag nil
)
(while l
(setq b (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))
)
)
);;end if (not l)
);;end progn
);;(setq ss (ssget))
(princ)
)
问题在几个月前写过代码，有空看看g版的代码
太历害了 学习了
学习那学习那
学习那学习那
学习了