一个实现梁交线自动断开的程序，非实用(源码)

蒹葭_Keirll

2. (defun c:ddd
   
3.   (/ pfir pt p1 p2 p3 p4 pt lobj1 lobj2 key a b c d dist e1 e2 ept i j k ent
   
4.   l_int l_p1 l_p2 lay len len_int spt ss ptl)
   
5.   (vl-load-com)
   
6.   (command "ucs" "w")
   
7.   (setq pfir (getpoint "sss"))
   
8.   (setq pt (polar pfir pi 100))(setq dist 100)
   
9.   (setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))
   
10.   (setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))
    
11.   (setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))
    
12.   (setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))
    
13.   (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
    
14.   ;(setq line1 (entlast))
    
15.   (setq lobj1 (vlax-ename->vla-object (entlast)))
    
16.   (entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))
    
17.   ;(setq line2 (entlast))
    
18.   (setq lobj2 (vlax-ename->vla-object (entlast)))
    
19.   (setq key nil)
    
20.   (while (AND (/= (car key) 3) (/= (car key) 11))
    
21.     (setq key (grread nil 1 0)
    
22.           pt (cadr key)
    
23.     ) ;end set
    
24.     (setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))
    
25.     (setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))
    
26.     (setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))
    
27.     (setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))
    
28.     (vla-put-startpoint lobj1 (vlax-3d-point p1))
    
29.     (vla-put-endpoint lobj1 (vlax-3d-point p2))
    
30.     (vla-put-startpoint lobj2 (vlax-3d-point p3))
    
31.     (vla-put-endpoint lobj2 (vlax-3d-point p4))
    
32.   ); end while
    
33. 
    
34.   (setq ptl '())
    
35.   (setq ptl (append (append (append (append ptl (list p1)) (list p2)) (list p4)) (list p3)))
    
36.   (setq ss (ssget "CP" ptl (list (cons 0 "LINE")(cons 8 "梁虚线,梁实线"))))
    
37.   (setq i 0
    
38.         l_p1 '() l_p2 '() l_int '()
    
39.         len (sslength ss)
    
40.   );end set
    
41.   (setq lay (vla-get-layer (vlax-ename->vla-object (ssname ss 0))))
    
42.   
    
43.   (repeat len ;把直线端点存入表中
    
44.     (setq ent (vlax-ename->vla-object (ssname ss i))
    
45.           i (+ 1 i)
    
46.           p1 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint ent)))
    
47.           p2 (vlax-safearray->list (vlax-variant-value (vla-get-endpoint ent)))
    
48.           l_p1 (cons p1 l_p1)
    
49.           l_p2 (cons p2 l_p2)
    
50.     );end set
    
51.   );end repeat
    
52.   (command "erase" ss "")
    
53.   (setq i 0)
    
54.   (repeat len
    
55.     (setq p1 (nth i l_p1)
    
56.           p2 (nth i l_p2)
    
57.           j 0
    
58.     );end set
    
59.     (repeat len ;计算某线与其他所有线的交点
    
60.       (if (/= j i)
    
61.         (setq p3 (nth j l_p1)
    
62.               p4 (nth j l_p2)
    
63.               j (+ 1 j)
    
64.               pt (inters p1 p2 p3 p4)
    
65.               l_int (if (AND pt (unequal pt p1)(unequal pt p2)) (cons pt l_int) l_int)
    
66.         );end set
    
67.         (setq j (+ 1 j))
    
68.       );end if
    
69.     );end repeat
    
70.     (setq l_int (cons p2 (cons p1 l_int)))
    
71.     (if (< (abs(- (car p1) (car p2))) 0.0001) ;排序
    
72.       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))) ))
    
73.       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (car e1) (car e2)))) ))
    
74.     );end if
    
75.     (setq len_int (length l_int)
    
76.           a (nth 0 l_int) b (nth 1 l_int)
    
77.           c (nth (- len_int 1) l_int)
    
78.           d (nth (- len_int 2) l_int)
    
79.     ) ;end set
    
80.     (if (< (distance a b) (distance c d)) (setq l_int (reverse l_int)))
    
81.     (setq k 0)
    
82.     (repeat (/ (length l_int) 2) ;画新线
    
83.       (setq spt (nth k l_int) ept (nth (+ k 1) l_int) k (+ k 2) )
    
84.       (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept) (cons 8 lay)))
    
85.     ) ;end repeat
    
86.     (setq l_int '() i (+ 1 i))
    
87.   );end repeat
    
88.   
    
89.   (command "ucs" "p")
    
90. ) ;end fun
    
91. 
    
92. 
    
93. (defun unequal (a b)
    
94.   (if (equal a b) nil T)
    
95. ) ;end fun

(defun c:ddd<br />   (/ pfir pt p1 p2 p3 p4 pt lobj1 lobj2 key a b c d dist e1 e2 ept i j k ent<br />   l_int l_p1 l_p2 lay len len_int spt ss ptl)<br />   (vl-load-com)<br />   (command "ucs" "w")<br />   (setq pfir (getpoint "sss"))<br />   (setq pt (polar pfir pi 100))(setq dist 100)<br />   (setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))<br />   (setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))<br />   (setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))<br />   (setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))<br />   (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))<br />   ;(setq line1 (entlast))<br />   (setq lobj1 (vlax-ename->vla-object (entlast)))<br />   (entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))<br />   ;(setq line2 (entlast))<br />   (setq lobj2 (vlax-ename->vla-object (entlast)))<br />   (setq key nil)<br />   (while (AND (/= (car key) 3) (/= (car key) 11))<br />     (setq key (grread nil 1 0)<br />           pt (cadr key)<br />     ) ;end set <br />     (setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))<br />     (setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))<br />     (setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))<br />     (setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))<br />     (vla-put-startpoint lobj1 (vlax-3d-point p1))<br />     (vla-put-endpoint lobj1 (vlax-3d-point p2))<br />     (vla-put-startpoint lobj2 (vlax-3d-point p3))<br />     (vla-put-endpoint lobj2 (vlax-3d-point p4))<br />   ); end while<br /> <br />   (setq ptl '())<br />   (setq ptl (append (append (append (append ptl (list p1)) (list p2)) (list p4)) (list p3)))<br />   (setq ss (ssget "CP" ptl (list (cons 0 "LINE")(cons 8 "梁虚线,梁实线"))))<br />   (setq i 0<br />         l_p1 '() l_p2 '() l_int '()<br />         len (sslength ss)<br />   );end set<br />   (setq lay (vla-get-layer (vlax-ename->vla-object (ssname ss 0))))<br />   <br />   (repeat len ;把直线端点存入表中<br />     (setq ent (vlax-ename->vla-object (ssname ss i))<br />           i (+ 1 i)<br />           p1 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint ent)))<br />           p2 (vlax-safearray->list (vlax-variant-value (vla-get-endpoint ent)))<br />           l_p1 (cons p1 l_p1)<br />           l_p2 (cons p2 l_p2)<br />     );end set<br />   );end repeat<br />   (command "erase" ss "")<br />   (setq i 0)<br />   (repeat len<br />     (setq p1 (nth i l_p1)<br />           p2 (nth i l_p2)<br />           j 0<br />     );end set<br />     (repeat len ;计算某线与其他所有线的交点<br />       (if (/= j i)<br />         (setq p3 (nth j l_p1)<br />               p4 (nth j l_p2)<br />               j (+ 1 j)<br />               pt (inters p1 p2 p3 p4)<br />               l_int (if (AND pt (unequal pt p1)(unequal pt p2)) (cons pt l_int) l_int)<br />         );end set<br />         (setq j (+ 1 j))<br />       );end if<br />     );end repeat<br />     (setq l_int (cons p2 (cons p1 l_int)))<br />     (if (< (abs(- (car p1) (car p2))) 0.0001) ;排序<br />       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))) ))<br />       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (car e1) (car e2)))) ))<br />     );end if<br />     (setq len_int (length l_int)<br />           a (nth 0 l_int) b (nth 1 l_int)<br />           c (nth (- len_int 1) l_int)<br />           d (nth (- len_int 2) l_int)<br />     ) ;end set<br />     (if (< (distance a b) (distance c d)) (setq l_int (reverse l_int)))<br />     (setq k 0)<br />     (repeat (/ (length l_int) 2) ;画新线<br />       (setq spt (nth k l_int) ept (nth (+ k 1) l_int) k (+ k 2) )<br />       (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept) (cons 8 lay)))<br />     ) ;end repeat<br />     (setq l_int '() i (+ 1 i))<br />   );end repeat<br />   <br />   (command "ucs" "p")<br /> ) ;end fun<br /> <br /> <br /> (defun unequal (a b)<br />   (if (equal a b) nil T)<br /> ) ;end fun

该贴已经同步到 蒹葭_Keirll的微博

bai2000

18楼挺好，能不能只修建一个方向的短线？

zzc83

好的东西，好的人品，顶一下
经测试 绘制双线终点不能捕捉，线不会自动断开，是不是要固定图层？
还有就是不能设置梁宽？

tjuzkj

有点意思,顶一下

xyp1964

可以继续完善

蒹葭_Keirll

zzc83 发表于 2012-12-7 21:52
好的东西，好的人品，顶一下
经测试 绘制双线终点不能捕捉，线不会自动断开，是不是要固定图层？
还有就 ...

图层是固定的，只能识别“梁虚线”跟“梁实线”这两个图层，但是只要把代码第35行的(cons  8 "梁虚线 梁实线")去掉，就不会识别图层了。
因为用了grread函数，所以不能捕捉，这个我也没有好的办法。
至于设置梁宽，这个比较容易加上去，只要把第7行的 dist 变量改为由用户输入就行了。

zyhandw

不错，写得很好，学习了

海盗曹

结构同行，赞一个~

crazylsp

2. (defun c:ddd
   
3.   (/ pfir pt p1 p2 p3 p4 pt lobj1 lobj2 key a b c d dist e1 e2 ept i j k ent
   
4.   l_int l_p1 l_p2 lay len len_int spt ss ptl)
   
5.   (vl-load-com)
   
6.   (command "ucs" "w")
   
7.   (setq pfir (getpoint "sss"))
   
8.   (setq dist(getreal "输入梁宽: "))
   
9.   (setq pt (getpoint pfir "sss"))
   
10.   (setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))
    
11.   (setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))
    
12.   (setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))
    
13.   (setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))
    
14.   (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
    
15.   ;(setq line1 (entlast))
    
16.   (setq lobj1 (vlax-ename->vla-object (entlast)))
    
17.   (entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))
    
18.   ;(setq line2 (entlast))
    
19.   (setq lobj2 (vlax-ename->vla-object (entlast)))
    
20.   (setq key nil)
    
21.   
    
22.   (setq ptl '())
    
23.   (setq ptl (append (append (append (append ptl (list p1)) (list p2)) (list p4)) (list p3)))
    
24.   (setq ss (ssget "CP" ptl (list (cons 0 "LINE")) ) )
    
25.   (setq i 0
    
26.         l_p1 '() l_p2 '() l_int '()
    
27.         len (sslength ss)
    
28.   );end set
    
29.   (setq lay (vla-get-layer (vlax-ename->vla-object (ssname ss 0))))
    
30.   
    
31.   (repeat len ;把直线端点存入表中
    
32.     (setq ent (vlax-ename->vla-object (ssname ss i))
    
33.           i (+ 1 i)
    
34.           p1 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint ent)))
    
35.           p2 (vlax-safearray->list (vlax-variant-value (vla-get-endpoint ent)))
    
36.           l_p1 (cons p1 l_p1)
    
37.           l_p2 (cons p2 l_p2)
    
38.     );end set
    
39.   );end repeat
    
40.   (command "erase" ss "")
    
41.   (setq i 0)
    
42.   (repeat len
    
43.     (setq p1 (nth i l_p1)
    
44.           p2 (nth i l_p2)
    
45.           j 0
    
46.     );end set
    
47.     (repeat len ;计算某线与其他所有线的交点
    
48.       (if (/= j i)
    
49.         (setq p3 (nth j l_p1)
    
50.               p4 (nth j l_p2)
    
51.               j (+ 1 j)
    
52.               pt (inters p1 p2 p3 p4)
    
53.               l_int (if (AND pt (unequal pt p1)(unequal pt p2)) (cons pt l_int) l_int)
    
54.         );end set
    
55.         (setq j (+ 1 j))
    
56.       );end if
    
57.     );end repeat
    
58.     (setq l_int (cons p2 (cons p1 l_int)))
    
59.     (if (< (abs(- (car p1) (car p2))) 0.0001) ;排序
    
60.       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))) ))
    
61.       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (car e1) (car e2)))) ))
    
62.     );end if
    
63.     (setq len_int (length l_int)
    
64.           a (nth 0 l_int) b (nth 1 l_int)
    
65.           c (nth (- len_int 1) l_int)
    
66.           d (nth (- len_int 2) l_int)
    
67.     ) ;end set
    
68.     (if (< (distance a b) (distance c d)) (setq l_int (reverse l_int)))
    
69.     (setq k 0)
    
70.     (repeat (/ (length l_int) 2) ;画新线
    
71.       (setq spt (nth k l_int) ept (nth (+ k 1) l_int) k (+ k 2) )
    
72.       (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept) (cons 8 lay)))
    
73.     ) ;end repeat
    
74.     (setq l_int '() i (+ 1 i))
    
75.   );end repeat
    
76.   
    
77.   (command "ucs" "p")
    
78. ) ;end fun
    
79. (defun unequal (a b)
    
80.   (if (equal a b) nil T)
    
81. ) ;end fun
    
82. 
    

(defun c:ddd<br />   (/ pfir pt p1 p2 p3 p4 pt lobj1 lobj2 key a b c d dist e1 e2 ept i j k ent<br />   l_int l_p1 l_p2 lay len len_int spt ss ptl)<br />   (vl-load-com)<br />   (command "ucs" "w")<br />   (setq pfir (getpoint "sss"))<br />   (setq dist(getreal "输入梁宽: "))<br />   (setq pt (getpoint pfir "sss"))<br />   (setq p1 (polar pfir (+ (angle pfir pt) (/ pi 2)) dist))<br />   (setq p2 (polar p1 (angle pfir pt) (distance pfir pt)))<br />   (setq p3 (polar pfir (+ (angle pfir pt) (/ pi 2)) (* dist -1)))<br />   (setq p4 (polar p3 (angle pfir pt) (distance pfir pt)))<br />   (entmake (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))<br />   ;(setq line1 (entlast))<br />   (setq lobj1 (vlax-ename->vla-object (entlast)))<br />   (entmake (list '(0 . "LINE") (cons 10 p3) (cons 11 p4)))<br />   ;(setq line2 (entlast))<br />   (setq lobj2 (vlax-ename->vla-object (entlast)))<br />   (setq key nil)<br />   <br />   (setq ptl '())<br />   (setq ptl (append (append (append (append ptl (list p1)) (list p2)) (list p4)) (list p3)))<br />   (setq ss (ssget "CP" ptl (list (cons 0 "LINE")) ) )<br />   (setq i 0<br />         l_p1 '() l_p2 '() l_int '()<br />         len (sslength ss)<br />   );end set<br />   (setq lay (vla-get-layer (vlax-ename->vla-object (ssname ss 0))))<br />   <br />   (repeat len ;把直线端点存入表中<br />     (setq ent (vlax-ename->vla-object (ssname ss i))<br />           i (+ 1 i)<br />           p1 (vlax-safearray->list (vlax-variant-value (vla-get-startpoint ent)))<br />           p2 (vlax-safearray->list (vlax-variant-value (vla-get-endpoint ent)))<br />           l_p1 (cons p1 l_p1)<br />           l_p2 (cons p2 l_p2)<br />     );end set<br />   );end repeat<br />   (command "erase" ss "")<br />   (setq i 0)<br />   (repeat len<br />     (setq p1 (nth i l_p1)<br />           p2 (nth i l_p2)<br />           j 0<br />     );end set<br />     (repeat len ;计算某线与其他所有线的交点<br />       (if (/= j i)<br />         (setq p3 (nth j l_p1)<br />               p4 (nth j l_p2)<br />               j (+ 1 j)<br />               pt (inters p1 p2 p3 p4)<br />               l_int (if (AND pt (unequal pt p1)(unequal pt p2)) (cons pt l_int) l_int)<br />         );end set<br />         (setq j (+ 1 j))<br />       );end if<br />     );end repeat<br />     (setq l_int (cons p2 (cons p1 l_int)))<br />     (if (< (abs(- (car p1) (car p2))) 0.0001) ;排序<br />       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (cadr e1) (cadr e2)))) ))<br />       (setq l_int (vl-sort l_int (function (lambda (e1 e2)(< (car e1) (car e2)))) ))<br />     );end if<br />     (setq len_int (length l_int)<br />           a (nth 0 l_int) b (nth 1 l_int)<br />           c (nth (- len_int 1) l_int)<br />           d (nth (- len_int 2) l_int)<br />     ) ;end set<br />     (if (< (distance a b) (distance c d)) (setq l_int (reverse l_int)))<br />     (setq k 0)<br />     (repeat (/ (length l_int) 2) ;画新线<br />       (setq spt (nth k l_int) ept (nth (+ k 1) l_int) k (+ k 2) )<br />       (entmake (list '(0 . "LINE") (cons 10 spt) (cons 11 ept) (cons 8 lay)))<br />     ) ;end repeat<br />     (setq l_int '() i (+ 1 i))<br />   );end repeat<br />   <br />   (command "ucs" "p")<br /> ) ;end fun<br /> (defun unequal (a b)<br />   (if (equal a b) nil T)<br /> ) ;end fun<br /> <br />

江豚大大

挺实用的一个啊~~十分感谢

bdboy

代码应该反过来用，已有梁线实现自动断开还算有用处，虽然网上有几个但识别率不高