[LISP程序]：删除Lwpolyline的重复点

eachy · 发表于 2005-9-27 18:54:01

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

;;删除Lwpolyline的重复点
;;自定义函数到“函数库”论坛下载
(defun c:RedupPoints (/ ss)
(if (setq ss (ssget '((0 . "lwpolyline"))))
(xd-ssmap
'(lambda (e / obj pts el header el1 tf ele el2)
(setq obj (vlax-ename->vla-object e)
pts (xd-list-split
(vlax-invoke obj 'intersectwith obj 0)
3
) ;_过滤了重复点
el (entget e)
header (xd-rmember (assoc 10 el) el)
)
(if (< (length pts) (xd-dxf el 90));_ 是否有重复点
(progn
(setq el1 (member (assoc 10 el) el)
tf t
)
(while tf
(if (setq ele (assoc 10 el1))
(if (not (vl-position ele (setq el1 (cdr el1))))
(setq el2 (cons ele el2))
)
(setq tf nil)
)
)
(entmod
(append
(subst (cons 90 (length pts))
(assoc 90 header)
header
)
(reverse el2)
)
)
)
)
)
ss
)
)
(princ)
)

;;删除Lwpolyline的重复点 
;;自定义函数到“函数库”论坛下载 
(defun c:RedupPoints (/ ss) 
  (if (setq ss (ssget '((0 . "lwpolyline")))) 
    (xd-ssmap 
      '(lambda (e / obj pts el header el1 tf ele el2) 
         (setq obj    (vlax-ename->vla-object e) 
               pts    (xd-list-split                        
                        (vlax-invoke obj 'intersectwith obj 0) 
                        3 
                      ) ;_过滤了重复点 
               el     (entget e) 
               header (xd-rmember (assoc 10 el) el) 
         ) 
         (if (< (length pts) (xd-dxf el 90));_ 是否有重复点 
           (progn 
             (setq el1 (member (assoc 10 el) el) 
                   tf  t 
             ) 
             (while tf 
               (if (setq ele (assoc 10 el1)) 
                 (if (not (vl-position ele (setq el1 (cdr el1)))) 
                   (setq el2 (cons ele el2)) 
                 ) 
                 (setq tf nil) 
               ) 
             ) 
             (entmod 
               (append 
                 (subst        (cons 90 (length pts)) 
                        (assoc 90 header) 
                        header 
                 ) 
                 (reverse el2) 
               ) 
             ) 
           ) 
         ) 
       ) 
      ss 
    ) 
  ) 
  (princ) 
)

附件为编译的独立版本

啵浪鼓 · 发表于 2005-9-27 21:23:49

自定义函数到“函数库”论坛下载
在哪里，找不着，能不能将你说的“自定义函数”一并加载你的程序中然后再贴出来？

eachy · 发表于 2005-9-27 22:02:41

最初由啵浪鼓发布
[B]自定义函数到“函数库”论坛下载
在哪里，找不着，能不能将你说的“自定义函数”一并加载你的程序中然后再贴出来？ [/B]

应用请下载附件，学习请参考
http://www.xdcad.net/forum/forumdisplay.php?s=&forumid=50

petertian · 发表于 2005-9-28 16:02:38

最初由 eachy 发布
[B]
应用请下载附件，学习请参考
[url]http://... [/B]

xd-list-split ,xd-remember函数找不见呀！斑竹！

eachy · 发表于 2005-9-28 19:23:21

http://p4.xdcad.net/forum/showthread.php?s=&threadid=451886

xd-list-split -> lst-split
xd-rmember -> lst-before

aeo · 发表于 2005-9-28 21:03:40

http://p4.xdcad.net/forum/showth ... 2278580#post2278580

aeo · 发表于 2005-9-28 23:50:30

最初由 eachy 发布
[B]http://p4.xdcad.net/forum/showthread.php?s=&threadid=451886

xd-list-split -> lst-split
xd-rmember -> lst-before [/B]

header-->(vl-remove-if '(lambda(x)(if(= 10(car x))(setq y t))y) el)

狂刀 · 发表于 2005-10-6 05:10:54

另一个供选程序。可处理近似闭合点。
http://p4.xdcad.net/forum/showth ... 2292292#post2292292

gufengyin · 发表于 2005-11-7 16:30:42

贴出来的那个LISP程序好像不行哦

  可否提供一个LISP的程序？

还有那个编译了的文件可否把删除多段的重复点，修改一下，
也可以删除二维多段线（POLYLINE）的重复点？

               谢谢

WHGF · 发表于 2006-4-21 08:15:47

这样的程序最好采用纯LISP写，通用性强。

wsywdyll · 发表于 2006-4-27 16:57:46

我编的运行问题多。从楼主那里学了不少。。。

lihy203 · 发表于 2009-3-24 09:44:35

学习!

evilweng · 发表于 2009-3-24 17:52:41

感谢楼主

lihy203 · 发表于 2009-3-25 17:59:20

附件下不了啊！
我正需要此程序，因为是刚学习，所以还都不会

zhuxiaoming · 发表于 2009-4-6 16:02:17

非常感谢诶

账号		自动登录	找回密码
密码			立即注册

[LISP程序]：删除Lwpolyline的重复点

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

关于删除多段线的重复点