2多段线延伸相交捡懒

树櫴希德

1. (defun vxs(e / p a b n ob q et d d1 en et)
   
2.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
   
3.     (cond((="LWPOLYLINE"et)
   
4.     (repeat(length a)(setq b (nth n a) n (+ n 1))
   
5.       (if (= 10 (car b))(progn
   
6.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
   
7.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
   
8.           (setq p (list q)))))))
   
9.    ((="POLYLINE"et)
   
10.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    
11.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
    
12.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
    
13.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
    
14.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    
15.     (setq p(reverse p))))P)
    
16. 
    
17. 
    
18. 
    
19. ;;示例(HHickSegEndPt (car(setq en(entsel))) (cadr en))
    
20. 
    
21. 
    
22. (defun HHickSegEndPt (obj p / pp n)
    
23.   (setq  pp (vlax-curve-getclosestpointto obj (trans p 1 0))
    
24.   n  (fix (vlax-curve-getparamatpoint obj pp))
    
25.   )
    
26. 
    
27.   (setq ll (length (vxs obj)));;避免最后一个点出创，加个判断(多这一句)
    
28. 
    
29.   (list
    
30.     (vlax-curve-getPointAtParam obj n)
    
31.     (if  (> (+ n 1) (- ll 1))
    
32.       (vlax-curve-getPointAtParam obj 1);;避免最后一个点出创，加个判断(多这一句)
    
33.       (vlax-curve-getPointAtParam obj (1+ n))
    
34.     )
    
35.   )
    
36. )
    
37. 
    
38. ;3、点表生成多段线
    
39. (defun makepl (lst / pt)
    
40. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "XDDX") (cons 90 (length lst)) (cons 70 128))
    
41.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
    
42.   ) )
    
43. 
    
44. (defun c:ed1 (/ p1 p2 j1 j2 jd a b ) ;p1 p2 j1 j2 jd
    
45. 
    
46. (setq p1 (entsel "\n请选择多段线需要延伸端点1：")
    
47.       p2 (entsel "\n请选择多段线需要延伸端点1：")
    
48.       )
    
49. (setq j1 (HHickSegEndPt (car p1) (cadr p1))
    
50.       j2 (HHickSegEndPt (car p2) (cadr p2))
    
51.       )
    
52.   (setq jd (inters (CAR J1)(CADR J1) (CAR J2)(CADR J2) nil)
    
53. )
    
54.   (setq a (vxs (car p1)   ) b (vxs (car p2)   )
    
55.   )
    
56. (if (  >   (distance (CAR J1) jd)  (distance (CAdR J1) jd)  ) (setq a a) (setq a (reverse a) ) )
    
57.   (if (  >   (distance (CAR J2) jd)  (distance (CAdR J2) jd)  ) (setq b (reverse b) ) (setq b b)  )
    
58. (makepl (append a (list jd)    b )   )
    
59.   (entdel (car p1)) (entdel (car p2))
    
60.   (PRINC)
    
61.   )

(defun vxs(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="POLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> <br /> <br /> <br /> ;;示例(HHickSegEndPt (car(setq en(entsel))) (cadr en))<br /> <br /> <br /> (defun HHickSegEndPt (obj p / pp n)<br />   (setq  pp (vlax-curve-getclosestpointto obj (trans p 1 0))<br />   n  (fix (vlax-curve-getparamatpoint obj pp))<br />   )<br /> <br />   (setq ll (length (vxs obj)));;避免最后一个点出创，加个判断(多这一句)<br /> <br />   (list<br />     (vlax-curve-getPointAtParam obj n)<br />     (if  (> (+ n 1) (- ll 1))<br />       (vlax-curve-getPointAtParam obj 1);;避免最后一个点出创，加个判断(多这一句)<br />       (vlax-curve-getPointAtParam obj (1+ n))<br />     )<br />   )<br /> )<br /> <br /> ;3、点表生成多段线<br /> (defun makepl (lst / pt)<br /> (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "XDDX") (cons 90 (length lst)) (cons 70 128))<br />       (mapcar '(lambda (pt)(cons 10 pt)) lst ))<br />   ) )<br /> <br /> (defun c:ed1 (/ p1 p2 j1 j2 jd a b ) ;p1 p2 j1 j2 jd<br /> <br /> (setq p1 (entsel "\n请选择多段线需要延伸端点1：")<br />       p2 (entsel "\n请选择多段线需要延伸端点1：")<br />       )<br /> (setq j1 (HHickSegEndPt (car p1) (cadr p1))<br />       j2 (HHickSegEndPt (car p2) (cadr p2))<br />       )<br />   (setq jd (inters (CAR J1)(CADR J1) (CAR J2)(CADR J2) nil) <br /> )<br />   (setq a (vxs (car p1)   ) b (vxs (car p2)   )<br />   )<br /> (if (  >   (distance (CAR J1) jd)  (distance (CAdR J1) jd)  ) (setq a a) (setq a (reverse a) ) )<br />   (if (  >   (distance (CAR J2) jd)  (distance (CAdR J2) jd)  ) (setq b (reverse b) ) (setq b b)  )<br /> (makepl (append a (list jd)    b )   )<br />   (entdel (car p1)) (entdel (car p2))<br />   (PRINC)<br />   )

yanshengjiang

请问这个和cad的倒角是不是一样的

树櫴希德

重复多段线 重复表判别 73哥函数

1. (defun plinexy(e / p a b n ob q et d d1 en et)
   
2.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
   
3.     (cond((="LWPOLYLINE"et)
   
4.     (repeat(length a)(setq b (nth n a) n (+ n 1))
   
5.       (if (= 10 (car b))(progn
   
6.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
   
7.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
   
8.           (setq p (list q)))))))
   
9.    ((="POLYLINE"et)
   
10.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
    
11.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
    
12.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
    
13.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
    
14.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
    
15.     (setq p(reverse p))))P)
    
16. 
    
17. 
    
18. (defun lst-(l1 l2 fuz / a l)
    
19.   (while l1
    
20.       (setq a(car l1)l1(cdr l1))
    
21.       (or(vl-some(function(lambda(x)(equal a x fuz)))l2)
    
22.    (setq l(cons a l))))
    
23.       (reverse l))
    
24. 
    
25. (defun lst-1 (l1 l2 fuz / l)
    
26.   (if l2
    
27.     (progn
    
28.       (vl-every(function(lambda(a)
    
29.         (or(vl-some(function(lambda(x)(equal a x fuz)))l2)
    
30.            (setq l(cons a l)))))l1)
    
31.       (reverse l))
    
32.     l1))
    
33. 
    
34.    
    
35. 
    
36. (setq p1(lst-  (plinexy (car(entsel "\n请选择一条线："))) (plinexy (car(entsel "\n请选择另一条线："))) 0.0001 ))
    

(defun plinexy(e / p a b n ob q et d d1 en et)<br />     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)<br />     (cond((="LWPOLYLINE"et)<br />     (repeat(length a)(setq b (nth n a) n (+ n 1))<br />       (if (= 10 (car b))(progn<br />         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))<br />         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))<br />           (setq p (list q)))))))<br />    ((="POLYLINE"et)<br />     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))<br />     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")<br />       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))<br />       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))<br />       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))<br />     (setq p(reverse p))))P)<br /> <br /> <br /> (defun lst-(l1 l2 fuz / a l)<br />   (while l1<br />       (setq a(car l1)l1(cdr l1))<br />       (or(vl-some(function(lambda(x)(equal a x fuz)))l2)<br />    (setq l(cons a l))))<br />       (reverse l))<br /> <br /> (defun lst-1 (l1 l2 fuz / l)<br />   (if l2<br />     (progn<br />       (vl-every(function(lambda(a)<br />         (or(vl-some(function(lambda(x)(equal a x fuz)))l2)<br />            (setq l(cons a l)))))l1)<br />       (reverse l))<br />     l1))<br /> <br />    <br /> <br /> (setq p1(lst-  (plinexy (car(entsel "\n请选择一条线："))) (plinexy (car(entsel "\n请选择另一条线："))) 0.0001 ))<br />

树櫴希德

1. (defun linezb (pp /)
   
2. (list (cdr(assoc 10 (entget pp))) (cdr(assoc 11 (entget pp)))  )
   
3.   )
   
4. 
   
5. ;3、点表生成多段线
   
6. (defun makepl (lst / pt)
   
7. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "XDDX") (cons 90 (length lst)) (cons 70 128))
   
8.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
   
9.   ) )
   
10. 
    
11. (defun c:ed2 ( / p1 p2 j1 j2 jd a b  ) ;p1 p2 j1 j2 jd a b
    
12. 
    
13. (setq p1 (entsel "\n请选择直线需要延伸端点1：")
    
14.       p2 (entsel "\n请选择直线需要延伸端点1：")
    
15.       )
    
16. (setq j1 (linezb (car p1))
    
17.       j2 (linezb (car p2))
    
18.       )
    
19.   (setq jd (inters (CAR J1)(CADR J1) (CAR J2)(CADR J2) nil)
    
20. )
    
21.   (setq a (linezb (car p1)   ) b (linezb (car p2)   )
    
22.   )
    
23. (if (  >   (distance (CAR J1) jd)  (distance (CAdR J1) jd)  ) (setq a a) (setq a (reverse a) ) )
    
24.   (if (  >   (distance (CAR J2) jd)  (distance (CAdR J2) jd)  ) (setq b (reverse b) ) (setq b b)  )
    
25. (makepl (append a (list jd)    b )   )
    
26.   (entdel (car p1)) (entdel (car p2))
    
27.   (PRINC)
    
28.   )

(defun linezb (pp /)<br /> (list (cdr(assoc 10 (entget pp))) (cdr(assoc 11 (entget pp)))  )<br />   )<br /> <br /> ;3、点表生成多段线<br /> (defun makepl (lst / pt)<br /> (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") '(8 . "XDDX") (cons 90 (length lst)) (cons 70 128))<br />       (mapcar '(lambda (pt)(cons 10 pt)) lst ))<br />   ) )<br /> <br /> (defun c:ed2 ( / p1 p2 j1 j2 jd a b  ) ;p1 p2 j1 j2 jd a b <br /> <br /> (setq p1 (entsel "\n请选择直线需要延伸端点1：")<br />       p2 (entsel "\n请选择直线需要延伸端点1：")<br />       )<br /> (setq j1 (linezb (car p1))<br />       j2 (linezb (car p2))<br />       )<br />   (setq jd (inters (CAR J1)(CADR J1) (CAR J2)(CADR J2) nil) <br /> )<br />   (setq a (linezb (car p1)   ) b (linezb (car p2)   )<br />   )<br /> (if (  >   (distance (CAR J1) jd)  (distance (CAdR J1) jd)  ) (setq a a) (setq a (reverse a) ) )<br />   (if (  >   (distance (CAR J2) jd)  (distance (CAdR J2) jd)  ) (setq b (reverse b) ) (setq b b)  )<br /> (makepl (append a (list jd)    b )   )<br />   (entdel (car p1)) (entdel (car p2))<br />   (PRINC)<br />   )

yp9819

老师 你好 我有个问题，想请您看看，也是关于PLINE延伸相交的问题。详细见http://bbs.mjtd.com/thread-181474-1-1.html 谢谢。相信您能解决，好吧

海尔

海尔

~~~~

海尔

海尔

999999

支持支持，多谢楼主分享

dmxcs

FILLET？？