一个实现梁交线自动断开的程序，非实用(源码)
(defun c:ddd(/ pfir pt p1 p2 p3 p4 pt lobj1 lobj2 key a b c d dist e1 e2 ept i j k ent
l_int l_p1 l_p2 lay len len_int spt ss ptl)
(vl-load-com)
(command "ucs" "w")
(setq pfir (getpoint "sss"))
(setq pt (polar pfir pi 100))(setq dist 100)
(setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))
(setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))
(setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))
(setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))
(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
;(setq line1 (entlast))
(setq lobj1 (vlax-ename->vla-object (entlast)))
(entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))
;(setq line2 (entlast))
(setq lobj2 (vlax-ename->vla-object (entlast)))
(setq key nil)
(while (AND (/= (car key) 3) (/= (car key) 11))
(setq key (grread nil 1 0)
pt (cadr key)
) ;end set
(setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))
(setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))
(setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))
(setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))
(vla-put-startpoint lobj1 (vlax-3d-point p1))
(vla-put-endpoint lobj1 (vlax-3d-point p2))
(vla-put-startpoint lobj2 (vlax-3d-point p3))
(vla-put-endpoint lobj2 (vlax-3d-point p4))
); end while
(setq ptl '())
(setq ptl (append (append (append (append ptl (list p1)) (list p2)) (list p4)) (list p3)))
(setq ss (ssget "CP" ptl (list (cons 0 "LINE")(cons 8 "梁虚线,梁实线"))))
(setq i 0
l_p1 '() l_p2 '() l_int '()
len (sslength ss)
);end set
(setq lay (vla-get-layer (vlax-ename->vla-object (ssname ss 0))))
(repeat len ;把直线端点存入表中
(setq ent (vlax-ename->vla-object (ssname ss i))
i (+ 1 i)
p1 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint ent)))
p2 (vlax-safearray->list (vlax-variant-value (vla-get-endpoint ent)))
l_p1 (cons p1 l_p1)
l_p2 (cons p2 l_p2)
);end set
);end repeat
(command "erase" ss "")
(setq i 0)
(repeat len
(setq p1 (nth i l_p1)
p2 (nth i l_p2)
j 0
);end set
(repeat len ;计算某线与其他所有线的交点
(if (/= j i)
(setq p3 (nth j l_p1)
p4 (nth j l_p2)
j (+ 1 j)
pt (inters p1 p2 p3 p4)
l_int (if (AND pt (unequal pt p1)(unequal pt p2)) (cons pt l_int) l_int)
);end set
(setq j (+ 1 j))
);end if
);end repeat
(setq l_int (cons p2 (cons p1 l_int)))
(if (< (abs(- (car p1) (car p2))) 0.0001) ;排序
(setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))) ))
(setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (car e1) (car e2)))) ))
);end if
(setq len_int (length l_int)
a (nth 0 l_int) b (nth 1 l_int)
c (nth (- len_int 1) l_int)
d (nth (- len_int 2) l_int)
) ;end set
(if (< (distance a b) (distance c d)) (setq l_int (reverse l_int)))
(setq k 0)
(repeat (/ (length l_int) 2) ;画新线
(setq spt (nth k l_int) ept (nth (+ k 1) l_int) k (+ k 2) )
(entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept) (cons 8 lay)))
) ;end repeat
(setq l_int '() i (+ 1 i))
);end repeat
(command "ucs" "p")
) ;end fun
(defun unequal (a b)
(if (equal a b) nil T)
) ;end fun
http://bbs.mjtd.com/xwb/images/bgimg/icon_logo.png 该贴已经同步到 蒹葭_Keirll的微博 18楼挺好，能不能只修建一个方向的短线？ 本帖最后由 zzc83 于 2012-12-7 21:58 编辑
好的东西，好的人品，顶一下
经测试 绘制双线终点不能捕捉，线不会自动断开，是不是要固定图层？
还有就是不能设置梁宽？
有点意思,顶一下 可以继续完善 zzc83 发表于 2012-12-7 21:52 static/image/common/back.gif
好的东西，好的人品，顶一下
经测试 绘制双线终点不能捕捉，线不会自动断开，是不是要固定图层？
还有就 ...
图层是固定的，只能识别“梁虚线”跟“梁实线”这两个图层，但是只要把代码第35行的(cons8 "梁虚线 梁实线")去掉，就不会识别图层了。
因为用了grread函数，所以不能捕捉，这个我也没有好的办法。
至于设置梁宽，这个比较容易加上去，只要把第7行的 dist 变量改为由用户输入就行了。 不错，写得很好，学习了 结构同行，赞一个~
修改了下可以输入梁宽和捕捉了，可惜没有动态
本帖最后由 crazylsp 于 2012-12-9 13:39 编辑(defun c:ddd
(/ pfir pt p1 p2 p3 p4 pt lobj1 lobj2 key a b c d dist e1 e2 ept i j k ent
l_int l_p1 l_p2 lay len len_int spt ss ptl)
(vl-load-com)
(command "ucs" "w")
(setq pfir (getpoint "sss"))
(setq dist(getreal "输入梁宽: "))
(setq pt (getpoint pfir "sss"))
(setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))
(setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))
(setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))
(setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))
(entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
;(setq line1 (entlast))
(setq lobj1 (vlax-ename->vla-object (entlast)))
(entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))
;(setq line2 (entlast))
(setq lobj2 (vlax-ename->vla-object (entlast)))
(setq key nil)
(setq ptl '())
(setq ptl (append (append (append (append ptl (list p1)) (list p2)) (list p4)) (list p3)))
(setq ss (ssget "CP" ptl (list (cons 0 "LINE")) ) )
(setq i 0
l_p1 '() l_p2 '() l_int '()
len (sslength ss)
);end set
(setq lay (vla-get-layer (vlax-ename->vla-object (ssname ss 0))))
(repeat len ;把直线端点存入表中
(setq ent (vlax-ename->vla-object (ssname ss i))
i (+ 1 i)
p1 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint ent)))
p2 (vlax-safearray->list (vlax-variant-value (vla-get-endpoint ent)))
l_p1 (cons p1 l_p1)
l_p2 (cons p2 l_p2)
);end set
);end repeat
(command "erase" ss "")
(setq i 0)
(repeat len
(setq p1 (nth i l_p1)
p2 (nth i l_p2)
j 0
);end set
(repeat len ;计算某线与其他所有线的交点
(if (/= j i)
(setq p3 (nth j l_p1)
p4 (nth j l_p2)
j (+ 1 j)
pt (inters p1 p2 p3 p4)
l_int (if (AND pt (unequal pt p1)(unequal pt p2)) (cons pt l_int) l_int)
);end set
(setq j (+ 1 j))
);end if
);end repeat
(setq l_int (cons p2 (cons p1 l_int)))
(if (< (abs(- (car p1) (car p2))) 0.0001) ;排序
(setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))) ))
(setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (car e1) (car e2)))) ))
);end if
(setq len_int (length l_int)
a (nth 0 l_int) b (nth 1 l_int)
c (nth (- len_int 1) l_int)
d (nth (- len_int 2) l_int)
) ;end set
(if (< (distance a b) (distance c d)) (setq l_int (reverse l_int)))
(setq k 0)
(repeat (/ (length l_int) 2) ;画新线
(setq spt (nth k l_int) ept (nth (+ k 1) l_int) k (+ k 2) )
(entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept) (cons 8 lay)))
) ;end repeat
(setq l_int '() i (+ 1 i))
);end repeat
(command "ucs" "p")
) ;end fun
(defun unequal (a b)
(if (equal a b) nil T)
) ;end fun
挺实用的一个啊~~十分感谢 代码应该反过来用，已有梁线实现自动断开还算有用处，虽然网上有几个但识别率不高