求把一个多段线角点连线的代码

lisp_beginner

各位大师，如图，谢谢

marting

试试

1. (defun c:tt (/ a d e f i l n v x)
   
2.   (if (setq e (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))
   
3.     (progn (setq l (entget (ssname e 0))
   
4.                  l (cons (assoc 10 (reverse l)) l)
   
5.                  f (lambda (x) (reverse (cdr x)))
   
6.                  d 1e308
   
7.                  n 0
   
8.            )
   
9.            (while (setq a (assoc 10 l))
   
10.              (cond ((not v) (setq v (cons (cdr a) v)))
    
11.                    ((equal (car v) (cdr a) 1e-3))
    
12.                    ((< (setq x (distance (cdr a) (car v))) d)
    
13.                     (setq d x
    
14.                           i n
    
15.                           v (cons (cdr a) v)
    
16.                     )
    
17.                    )
    
18.                    ((setq v (cons (cdr a) v)))
    
19.              )
    
20.              (setq l (cdr (member a l))
    
21.                    n (1+ n)
    
22.              )
    
23.            )
    
24.            (setq v (f v))
    
25.            (repeat i (setq v (reverse (cons (car v) (f v)))))
    
26.            (repeat (- (/ (length v) 2) 2)
    
27.              (entmake (list '(0 . "LINE")
    
28.                             (cons 10 (car (setq v (f (f v)))))
    
29.                             (cons 11 (last v))
    
30.                       )
    
31.              )
    
32.            )
    
33.     )
    
34.   )
    
35.   (princ)
    
36. )
    

(defun c:tt (/ a d e f i l n v x)<br />   (if (setq e (ssget "_+.:E:S" '((0 . "LWPOLYLINE") (-4 . "&=") (70 . 1))))<br />     (progn (setq l (entget (ssname e 0))<br />                  l (cons (assoc 10 (reverse l)) l)<br />                  f (lambda (x) (reverse (cdr x)))<br />                  d 1e308<br />                  n 0<br />            )<br />            (while (setq a (assoc 10 l))<br />              (cond ((not v) (setq v (cons (cdr a) v)))<br />                    ((equal (car v) (cdr a) 1e-3))<br />                    ((< (setq x (distance (cdr a) (car v))) d)<br />                     (setq d x<br />                           i n<br />                           v (cons (cdr a) v)<br />                     )<br />                    )<br />                    ((setq v (cons (cdr a) v)))<br />              )<br />              (setq l (cdr (member a l))<br />                    n (1+ n)<br />              )<br />            )<br />            (setq v (f v))<br />            (repeat i (setq v (reverse (cons (car v) (f v)))))<br />            (repeat (- (/ (length v) 2) 2)<br />              (entmake (list '(0 . "LINE")<br />                             (cons 10 (car (setq v (f (f v)))))<br />                             (cons 11 (last v))<br />                       )<br />              )<br />            )<br />     )<br />   )<br />   (princ)<br /> )<br />

2767836360

很好支持谢谢分享

Lisphk

1. (defun connect (e / _point d d1 l p1 p2 a b n i)
   
2.   (setq _point vlax-curve-getpointatparam
   
3.         d      (vlax-curve-getdistatparam
   
4.                  e
   
5.                  (setq n (fix (+ 0.1 (vlax-curve-getendparam e))))
   
6.                )
   
7.   )
   
8.   (repeat (setq i (1+ n))
   
9.     (setq l (cons (setq p1 (_point e (setq i (1- i)))) l))
   
10.     (if (setq p2 (cadr l))
    
11.       (if (and (< (setq d1 (distance p1 p2)) d) (not (zerop d1)))
    
12.         (setq d d1
    
13.               a (rem (1+ i) n)
    
14.               b i
    
15.         )
    
16.       )
    
17.     )
    
18.   )
    
19.   (mapcar 'set '(a b) (list (max a b) (min a b)))
    
20.   (while (progn (setq a (rem (1+ a) n))
    
21.                 (setq b (rem (+ n (1- b)) n))
    
22.                 (not (= (rem (1+ a) n) b))
    
23.          )
    
24.     (entmake (list '(0 . "LINE")
    
25.                    (cons 10 (_point e a))
    
26.                    (cons 11 (_point e b))
    
27.              )
    
28.     )
    
29.   )
    
30. )
    
31. 
    
32. (defun c:tt ()
    
33.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
    
34.   (repeat (setq i (sslength ss))
    
35.     (connect (ssname ss (setq i (1- i))))
    
36.   )
    
37.   (princ)
    
38. )
    

(defun connect (e / _point d d1 l p1 p2 a b n i)<br />   (setq _point vlax-curve-getpointatparam<br />         d      (vlax-curve-getdistatparam<br />                  e<br />                  (setq n (fix (+ 0.1 (vlax-curve-getendparam e))))<br />                )<br />   )<br />   (repeat (setq i (1+ n))<br />     (setq l (cons (setq p1 (_point e (setq i (1- i)))) l))<br />     (if (setq p2 (cadr l))<br />       (if (and (< (setq d1 (distance p1 p2)) d) (not (zerop d1)))<br />         (setq d d1<br />               a (rem (1+ i) n)<br />               b i<br />         )<br />       )<br />     )<br />   )<br />   (mapcar 'set '(a b) (list (max a b) (min a b)))<br />   (while (progn (setq a (rem (1+ a) n))<br />                 (setq b (rem (+ n (1- b)) n))<br />                 (not (= (rem (1+ a) n) b))<br />          )<br />     (entmake (list '(0 . "LINE")<br />                    (cons 10 (_point e a))<br />                    (cons 11 (_point e b))<br />              )<br />     )<br />   )<br /> )<br /> <br /> (defun c:tt ()<br />   (setq ss (ssget '((0 . "LWPOLYLINE"))))<br />   (repeat (setq i (sslength ss))<br />     (connect (ssname ss (setq i (1- i))))<br />   )<br />   (princ)<br /> )<br />

tzfcn

不看图还真不好理解。

sicky111

两位大师动作神速。

xinyeyu

为还不够完美，有些顶点没连上