Lwpolyline消除重复点

iLisp

1. (defun c:tt (/ s e obj epam n pts)
   
2.   (if (setq s (ssget "+.:S" '((0 . "lwpolyline"))))
   
3.     (progn
   
4.       (setq e         (ssname s 0)
   
5.             obj         (vlax-ename->vla-object e)
   
6.             epam (vlax-curve-getendparam e)
   
7.             n         epam
   
8.       )
   
9.       (while (> epam -1)
   
10.         (setq p (vlax-curve-getpointatparam e epam))
    
11.         (if pts
    
12.           (if (vl-some '(lambda (x) (equal x p 1e-6)) pts)
    
13.             nil
    
14.             (setq pts (cons p pts))
    
15.           )
    
16.           (setq pts (cons p pts))
    
17.         )
    
18.         (setq epam (1- epam))
    
19.       )
    
20.       (if (/= n (length pts))
    
21.         (progn
    
22.           (if (vlax-curve-isclosed e)
    
23.             (setq pts (cons (last pts) (reverse (cdr (reverse pts)))))
    
24.           )
    
25.           (vlax-put obj
    
26.                     'Coordinates
    
27.                     (apply 'append
    
28.                            (mapcar '(lambda (x)
    
29.                                       (list (car x) (cadr x))
    
30.                                     )
    
31.                                    pts
    
32.                            )
    
33.                     )
    
34.           )
    
35.         )
    
36.       )
    
37.     )
    
38.   )
    
39.   (princ)
    
40. )

(defun c:tt (/ s e obj epam n pts)<br />   (if (setq s (ssget "+.:S" '((0 . "lwpolyline"))))<br />     (progn<br />       (setq e         (ssname s 0)<br />             obj         (vlax-ename->vla-object e)<br />             epam (vlax-curve-getendparam e)<br />             n         epam<br />       )<br />       (while (> epam -1)<br />         (setq p (vlax-curve-getpointatparam e epam))<br />         (if pts<br />           (if (vl-some '(lambda (x) (equal x p 1e-6)) pts)<br />             nil<br />             (setq pts (cons p pts))<br />           )<br />           (setq pts (cons p pts))<br />         )<br />         (setq epam (1- epam))<br />       )<br />       (if (/= n (length pts))<br />         (progn<br />           (if (vlax-curve-isclosed e)<br />             (setq pts (cons (last pts) (reverse (cdr (reverse pts)))))<br />           )<br />           (vlax-put obj<br />                     'Coordinates<br />                     (apply 'append<br />                            (mapcar '(lambda (x)<br />                                       (list (car x) (cadr x))<br />                                     )<br />                                    pts<br />                            )<br />                     )<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )

HLCAD

这个不错，如果能将处于直线上的各点再进行合并，则功能更加实用。

xhwcj@sina.com

学习学习中。。。。。。。。。。:):)

csharp

三个点一组再判断下是否共线，共线时去掉car