API应用 快速休整Pline

st788796

1. (defun c:tt (/ p pts pl sp ep npl ptl nnpl)
   
2.   (while (setq p (if pts
   
3.                    (getpoint (car pts) "\nPoint: ")
   
4.                    (getpoint "\nPoint: ")
   
5.                  )
   
6.          )
   
7.     (setq pts (cons p pts))
   
8.     (if        (> (length pts) 1)
   
9.       (mapcar '(lambda (p1 p2) (grdraw p1 p2 1)) pts (cdr pts))
   
10.     )
    
11.   )
    
12.   (if
    
13.     (and pts
    
14.          (setq
    
15.            ss (xdrx_pickset_getatpoint (last pts) '((0 . "lwpolyline")))
    
16.          )
    
17.     )
    
18.      (progn
    
19.        (setq ptl  (list (car pts) (last pts))
    
20.              pl          (ssname ss 0)
    
21.              sp          (xdrx_curve_getparamatpoint pl (car ptl))
    
22.              ep          (xdrx_curve_getparamatpoint pl (cadr ptl))
    
23.              nnpl (xdrx_pickset->ents (xdrx_curve_getsplitcurves pl sp ep))
    
24.        )
    
25.        (if (vlax-curve-isclosed pl)
    
26.          (xdrx_entity_delete
    
27.            (car
    
28.              (vl-sort
    
29.                nnpl
    
30.                '(lambda        (x1 x2)
    
31.                   (< (cadr (xdrx_getarea x1)) (cadr (xdrx_getarea x2)))
    
32.                 )
    
33.              )
    
34.            )
    
35.          )
    
36.          (mapcar '(lambda (x / info ppl)
    
37.                     (setq info (xdrx_curve_getpoint x)
    
38.                           ppl  (list (car info) (caddr info))
    
39.                     )
    
40.                     (if        (or (equal ppl ptl 1e-5)
    
41.                             (equal ppl (reverse ptl) 1e-5)
    
42.                         )
    
43.                       (xdrx_entity_delete x)
    
44.                     )
    
45.                   )
    
46.                  nnpl
    
47.          )
    
48.        )
    
49.        (setq npl  (apply 'xdrx_polyline_make pts)
    
50.              nnpl (vl-remove-if-not '(lambda (x) (entget x)) nnpl)
    
51.        )
    
52.        (vl-cmdf ".pedit" pl "j" npl)
    
53.        (if nnpl
    
54.          (foreach x nnpl (vl-cmdf x))
    
55.        )
    
56.        (vl-cmdf "")
    
57.        (vl-cmdf "")
    
58.      )
    
59.   )
    
60.   (princ)
    
61. )

(defun c:tt (/ p pts pl sp ep npl ptl nnpl)<br />   (while (setq p (if pts<br />                    (getpoint (car pts) "\nPoint: ")<br />                    (getpoint "\nPoint: ")<br />                  )<br />          )<br />     (setq pts (cons p pts))<br />     (if        (> (length pts) 1)<br />       (mapcar '(lambda (p1 p2) (grdraw p1 p2 1)) pts (cdr pts))<br />     )<br />   )<br />   (if<br />     (and pts<br />          (setq<br />            ss (xdrx_pickset_getatpoint (last pts) '((0 . "lwpolyline")))<br />          )<br />     )<br />      (progn<br />        (setq ptl  (list (car pts) (last pts))<br />              pl          (ssname ss 0)<br />              sp          (xdrx_curve_getparamatpoint pl (car ptl))<br />              ep          (xdrx_curve_getparamatpoint pl (cadr ptl))<br />              nnpl (xdrx_pickset->ents (xdrx_curve_getsplitcurves pl sp ep))<br />        )<br />        (if (vlax-curve-isclosed pl)<br />          (xdrx_entity_delete<br />            (car<br />              (vl-sort<br />                nnpl<br />                '(lambda        (x1 x2)<br />                   (< (cadr (xdrx_getarea x1)) (cadr (xdrx_getarea x2)))<br />                 )<br />              )<br />            )<br />          )<br />          (mapcar '(lambda (x / info ppl)<br />                     (setq info (xdrx_curve_getpoint x)<br />                           ppl  (list (car info) (caddr info))<br />                     )<br />                     (if        (or (equal ppl ptl 1e-5)<br />                             (equal ppl (reverse ptl) 1e-5)<br />                         )<br />                       (xdrx_entity_delete x)<br />                     )<br />                   )<br />                  nnpl<br />          )<br />        )<br />        (setq npl  (apply 'xdrx_polyline_make pts)<br />              nnpl (vl-remove-if-not '(lambda (x) (entget x)) nnpl)<br />        )<br />        (vl-cmdf ".pedit" pl "j" npl)<br />        (if nnpl<br />          (foreach x nnpl (vl-cmdf x))<br />        )<br />        (vl-cmdf "")<br />        (vl-cmdf "")<br />      )<br />   )<br />   (princ)<br /> )