【求助】有这样框选连线的工具吗？~~[G版已解决]期待竖向完善！
本帖最后由 daidong013 于 2012-9-15 10:17 编辑求助高手们！~有这样的工具吗？！~~
(defun c:DJLX (/ instpd p1 p2 minpt maxpt ss en pl pt)
(defun instpd (lst / a b c d)
(mapcar 'set '(a b c d) lst)
(if (not (apply 'inters (mapcar 'car (list a b c d))))
(if (equal (angle (car b) (car a)) (cadr a) (* 0.25 pi))
(list (list (car a) (car b)) (list (car c) (car d)))
(instpd (list a c b d))
)
(instpd (list a c d b))
)
)
(while (and
(setq p1 (getpoint "\n第一点: "))
(setq p2 (getcorner p1 "\n对角点: "))
)
(mapcar 'set
'(minpt maxpt)
(list (mapcar 'min p1 p2) (mapcar 'max p1 p2))
)
(setq ss (ssget "c" p1 p2 '((0 . "line,*polyline"))))
(if ss
(progn
(setq pl nil)
(repeat (setq n (sslength ss))
(setq en (ssname ss (setq n (1- n))))
(if (apply 'and
(mapcar '<=
minpt
(setq pt (vlax-curve-getStartPoint
(vlax-ename->vla-object en)
)
)
maxpt
)
)
(setq pl
(cons
(list pt
(angle pt
(mapcar '+
pt
(vlax-curve-getFirstDeriv
(vlax-ename->vla-object en)
(vlax-curve-getStartParam
(vlax-ename->vla-object en)
)
)
)
)
)
pl
)
)
(setq pl
(cons
(list (setq pt (vlax-curve-getEndPoint
(vlax-ename->vla-object en)
)
)
(angle pt
(mapcar '+
pt
(vlax-curve-getFirstDeriv
(vlax-ename->vla-object en)
(vlax-curve-getEndParam
(vlax-ename->vla-object en)
)
)
)
)
)
pl
)
)
)
)
(foreach n (instpd pl)
(entmake (list '(0 . "line")
'(62 . 1)
(cons 10 (car n))
(cons 11 (cadr n))
)
)
)
)
)
)
(princ)
) 各种 方向 都行 daidong013 发表于 2012-9-14 17:43
G版，如果图形变为竖向的时候好像有点问题！~~
或者判断以距离长的优先，不知可行否！！！
楼主，不知竖向的是否解决了？ Gu_xl 发表于 2012-9-14 15:33
G版能不能完善下竖向 一条两条线用直线连起来是比较方便，但线多了就比较麻烦一点了！~呵呵！~ 本帖最后由 Gu_xl 于 2012-9-14 16:10 编辑
;;选择对角点连线 ，By 明经通道 Gu_xl 2012.09.14
(defun c:DJLX(/ PTINBOX P1 P2 MINX MINY MAXX
MAXY SS PL N EN EL PT VERTEX
PTS DumpPoint)
(defun ptinbox(p mi_x mi_y ma_x ma_y)
(and (>= (car p) mi_x)
(>= (cadr p) mi_y)
(<= (car p) ma_x)
(<= (cadr p) ma_y)
)
)
(defun DumpPoint(ptLst fuzz / pt1 x)
(cond ((<= (length ptLst) 1) ptLst)
(t
(setq pt1 (car ptLst))
(cons pt1
(vl-remove-if
'(lambda (x) (equal pt1 x fuzz))
(DumpPoint (cdr ptLst) fuzz))
)
))
)
(while (and
(setq p1 (getpoint "\n第一点: "))
(setq p2 (getcorner p1 "\n对角点: "))
)
(setq minx (min (car p1) (car p2))
miny (min (cadr p1) (cadr p2))
maxx (max (car p1) (car p2))
maxy (max (cadr p1) (cadr p2))
)
(setq ss (ssget "c" p1 p2 '((0 . "line,*polyline"))))
(if ss
(progn
(setq pl nil)
(repeat (setq n (sslength ss))
(setq en (ssname ss (setq n (1- n))))
(cond
((= "LINE" (cdr (assoc 0 (setq el (entget en)))))
(if (ptinbox (setq pt (cdr (assoc 10 el)))
minx
miny
maxx
maxy)
(setq pl (cons (list (car pt) (cadr pt)) pl))
(if (ptinbox (setq pt (cdr (assoc 11 el)))
minx
miny
maxx
maxy)
(setq pl (cons (list (car pt) (cadr pt))pl))
)
)
)
((= "LWPOLYLINE" (cdr (assoc 0 el)))
(mapcar '(lambda (a)
(if (ptinbox (cdr a) minx miny maxx maxy)
(setq pl (cons (cdr a) pl))))
(vl-remove-if '(lambda (x) (/= 10 (car x))) el)
)
)
(t
(setq vertex
(vlax-safearray->list
(vlax-variant-value
(vla-get-Coordinates
(vlax-ename->vla-object en)
)
)
)
pts nil
)
(while vertex
(if
(ptinbox
(setq pt (list (car vertex) (cadr vertex)))
minx
miny
maxx
maxy)
(setq pl (cons pt pl))
)
(setq vertex (cdddr vertex))
)
)
)
)
(setq pl (DumpPoint pl 1e-6)
pl (vl-sort pl
'(lambda (a b)
(if (= (cadr a) (cadr b))
(< (car a) (car b))
(> (cadr a) (cadr b))
)
)
)
)
(while (setq p1 (car pl)
p2 (cadr pl)
)
(entmake (list '(0 . "line")
'(62 . 1)
(cons 10 p1)
(cons 11 p2)
)
)
(setq pl (cddr pl))
)
)
)
)
(princ)
)
还是版主牛啊 Gu_xl 发表于 2012-9-14 15:33 static/image/common/back.gif
G版出手果然非同凡响，赞赞赞！~
就是这样的效果,感谢感谢！~~ 本帖最后由 daidong013 于 2012-9-14 17:52 编辑
Gu_xl 发表于 2012-9-14 15:33 static/image/common/back.gif
G版，如果图形变为竖向的时候好像有点问题！~~
或者判断以距离长的优先，不知可行否！！！ G大的程序个个是经典，竖向的不晓得怎么改。改哪里？ 还有个问题就是在UCS下不能用 直接用连接 也不慢呢 留个记号，以后用得上