2条平行线闭合成多段线

脚印2012

求助：大神。运用lisp后。只能一边闭合，而且多生成了一条直线。希望框选后能直接生成闭合的多段线
        求助修改，谢谢！

lyoshi

15617556676 发表于 2019-8-1 15:23
你这个还需要判定一下起点和端点，要不又自相交叉的

2. (defun c:tt5(/ ss len en1 en2 data1 data2 pt1 pt2 pt3 pt4)
   
3.         (prompt "\nSelect 2 lwpolylines:")
   
4.         (setq ss (ssget '((0 . "lwpolyline,line"))))
   
5.         (setq len (sslength ss))
   
6.         (if (/= len 2)
   
7.                 (princ "\n不是2根! ---程序退出......")
   
8.                 (progn
   
9.                         (setq en1 (ssname ss 0) en2 (ssname ss 1))
   
10.                         (setq data1 (entget en1) data2 (entget en2))
    
11.                         (setq pt1 (cdr (assoc 10 data1)) pt2 (cdr (assoc 11 data1)))
    
12.                         (setq pt3 (cdr (assoc 10 data2)) pt4 (cdr (assoc 11 data2)))
    
13.                         ;; (PRINT pt1)
    
14.                         ;; (PRINT pt2)
    
15.                         ;; (PRINT pt3)
    
16.                         ;; (PRINT pt4)
    
17.                         (setq d1 (distance pt1 pt3))
    
18.                         (setq d2 (distance pt1 pt4))
    
19.                         (if (< d1 d2)
    
20.                                 ((command "line" pt1 pt3 "") (command "line" pt2 pt4 "") )
    
21.                                 ((command "line" pt1 pt4 "") (command "line" pt2 pt3 "") )
    
22.                         )
    
23.                 )
    
24.         )
    
25.         (princ)
    
26. )
    

(defun c:tt5(/ ss len en1 en2 data1 data2 pt1 pt2 pt3 pt4)<br />         (prompt "\nSelect 2 lwpolylines:")<br />         (setq ss (ssget '((0 . "lwpolyline,line"))))<br />         (setq len (sslength ss))<br />         (if (/= len 2)<br />                 (princ "\n不是2根! ---程序退出......")<br />                 (progn<br />                         (setq en1 (ssname ss 0) en2 (ssname ss 1))<br />                         (setq data1 (entget en1) data2 (entget en2))<br />                         (setq pt1 (cdr (assoc 10 data1)) pt2 (cdr (assoc 11 data1)))<br />                         (setq pt3 (cdr (assoc 10 data2)) pt4 (cdr (assoc 11 data2)))<br />                         ;; (PRINT pt1)<br />                         ;; (PRINT pt2)<br />                         ;; (PRINT pt3)<br />                         ;; (PRINT pt4)<br />                         (setq d1 (distance pt1 pt3))<br />                         (setq d2 (distance pt1 pt4))<br />                         (if (< d1 d2)<br />                                 ((command "line" pt1 pt3 "") (command "line" pt2 pt4 "") )<br />                                 ((command "line" pt1 pt4 "") (command "line" pt2 pt3 "") )<br />                         )<br />                 )<br />         )<br />         (princ)<br /> )<br />

xyp1964

dasha321 发表于 2021-7-5 15:52
你好，请问这个有源码啊，谢谢，正需要，楼上的不可以框选。

1. (defun c:tt () ;tt(平行线闭合成多段线)
   
2.   (defun abc (l1 l2 / p1 p2 p3 p4 s1 s2)
   
3.     (setq p1 (xyp-DXF 10 l1)
   
4.           p2 (xyp-DXF 11 l1)
   
5.           p3 (xyp-DXF 10 l2)
   
6.           p4 (xyp-DXF 11 l2)
   
7.     )
   
8.     (if        (inters p1 p4 p2 p3 nil)
   
9.       (progn
   
10.         (setq s1 (xyp-line p1 p3)
    
11.               s2 (xyp-line p2 p4)
    
12.         )
    
13.         (xyp-PeditJoin (xyp-list2ss (list l1 l2 s1 s2)) 0)
    
14.       )
    
15.       (progn
    
16.         (setq s1 (xyp-line p1 p4)
    
17.               s2 (xyp-line p2 p3)
    
18.         )
    
19.         (xyp-PeditJoin (xyp-list2ss (list l1 l2 s1 s2)) 0)
    
20.       )
    
21.     )
    
22.   )
    
23.   (if (setq ss (ssget '((0 . "line"))))
    
24.     (progn
    
25.       (setq lst        (xyp-Ss2List ss)
    
26.             lst        (vl-sort lst'(lambda (x y)(< (cadr (xyp-CurveMidPoint x))(cadr (xyp-CurveMidPoint y)))))
    
27.             lst        (xyp-List-Div lst 2)
    
28.       )
    
29.       (mapcar '(lambda (x)(if (= (length x) 2)(abc (car x) (cadr x))))lst)
    
30.     )
    
31.   )
    
32.   (princ)
    
33. )

(defun c:tt () ;tt(平行线闭合成多段线)<br />   (defun abc (l1 l2 / p1 p2 p3 p4 s1 s2)<br />     (setq p1 (xyp-DXF 10 l1)<br />           p2 (xyp-DXF 11 l1)<br />           p3 (xyp-DXF 10 l2)<br />           p4 (xyp-DXF 11 l2)<br />     )<br />     (if        (inters p1 p4 p2 p3 nil)<br />       (progn<br />         (setq s1 (xyp-line p1 p3)<br />               s2 (xyp-line p2 p4)<br />         )<br />         (xyp-PeditJoin (xyp-list2ss (list l1 l2 s1 s2)) 0)<br />       )<br />       (progn<br />         (setq s1 (xyp-line p1 p4)<br />               s2 (xyp-line p2 p3)<br />         )<br />         (xyp-PeditJoin (xyp-list2ss (list l1 l2 s1 s2)) 0)<br />       )<br />     )<br />   )<br />   (if (setq ss (ssget '((0 . "line"))))<br />     (progn<br />       (setq lst        (xyp-Ss2List ss)<br />             lst        (vl-sort lst'(lambda (x y)(< (cadr (xyp-CurveMidPoint x))(cadr (xyp-CurveMidPoint y)))))<br />             lst        (xyp-List-Div lst 2)<br />       )<br />       (mapcar '(lambda (x)(if (= (length x) 2)(abc (car x) (cadr x))))lst)<br />     )<br />   )<br />   (princ)<br /> )

15617556676

start4444 发表于 2019-8-1 11:02
你那个太繁琐了，简化了一下

你这个还需要判定一下起点和端点，要不又自相交叉的

start4444

你那个太繁琐了，简化了一下

tangjunasd58

直接PE就好

tangjunasd58

pe-m-j-距离-

xyp1964

dasha321

xyp1964 发表于 2019-8-5 22:56

你好，请问这个有源码啊，谢谢，正需要，楼上的不可以框选。

xj6019

你应该想多了，请先了解一下你说的你的楼上是干嘛的

dasha321

xyp1964 发表于 2021-7-5 20:52

真心地感谢你，再次感谢你。谢谢