[LISP函数]：LWPOLYLINE消重(函数)

aeo · 发表于 2005-9-28 20:49:24

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

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

×

硬写的，不要其他自定义函数

(defun lwpl-remove-duppoint (e / a a1 b b1 c c1 en j n new p p1 key)
(setq en (entget e))
(while (setq n (car en))
(if (= (car n) 90)
(setq j (cdr n))
)
(if (= (car n) 10)
(progn
(mapcar 'set '(p a b c) en)
(setq en (cddddr en)
key t
) ;_key进入dxf10
(if (equal p1 p 1e-4)
(setq j (1- j))
(if p1
(setq new (append new (list p1 a1 b1 c1)))
)
)
(mapcar 'set '(p1 a1 b1 c1) (list p a b c))
) ;_progn
(progn (if key
(setq new (append new (list p1 a1 b1 c1))
key nil
) ;_dxf10读完了.
)
(setq new (append new (list n))
en (cdr en)
)
)
) ;_if
) ;_while
(entmod (subst (cons 90 j) (assoc 90 new) new))
)

(defun lwpl-remove-duppoint (e / a a1 b b1 c c1 en j n new p p1 key) 
  (setq en (entget e)) 
  (while (setq n (car en)) 
    (if        (= (car n) 90) 
      (setq j (cdr n)) 
    ) 
    (if        (= (car n) 10) 
      (progn 
        (mapcar 'set '(p a b c) en) 
        (setq en  (cddddr en) 
              key t 
        ) ;_key进入dxf10 
        (if (equal p1 p 1e-4) 
          (setq j (1- j)) 
          (if p1 
            (setq new (append new (list p1 a1 b1 c1))) 
          ) 
        ) 
        (mapcar 'set '(p1 a1 b1 c1) (list p a b c)) 
      ) ;_progn 
      (progn (if key 
               (setq new (append new (list p1 a1 b1 c1)) 
                     key nil 
               ) ;_dxf10读完了. 
             ) 
             (setq new (append new (list n)) 
                   en  (cdr en) 
             ) 
      ) 
    ) ;_if 
  ) ;_while 
  (entmod (subst (cons 90 j) (assoc 90 new) new)) 
)

aeo · 发表于 2005-9-28 20:51:22

实例:

(defun c:plxc( / e)
(while(setq e(car(entsel "\n选LWPOLYLINE消重复点: ")))
(if (= "LWPOLYLINE"(cdr(assoc 0(entget e))))
(progn([URL=http://p4.xdcad.net/forum/showthread.php?s=&postid=2278580#post2278580][U][COLOR=red]lwpl-remove-duppoint[/COLOR][/U][/URL] e)(princ"...ok"))
(princ "\n没选到LWPOLYLINE")
)
)
(princ)
)

多选:

(defun c:plxc( / ss)
(if(setq ss(ssget '((0 . "LWPOLYLINE"))))
([URL=http://p4.xdcad.net/forum/showthread.php?s=&threadid=463104][U][COLOR=red]xd-SSMAP[/COLOR][/U][/URL] '(lambda(x)([URL=http://p4.xdcad.net/forum/showthread.php?s=&postid=2278580#post2278580][U][COLOR=red]lwpl-remove-duppoint[/COLOR][/U][/URL] x)) ss)
)
(princ)
)

WHGF · 发表于 2005-9-30 08:04:52

用纯LISP写，“不要其他自定义函数”使用上不受其它函数的限制，这样的程序好，可在没有VLISP的系统上运行，楼主对DXF的组码了解的非常透彻，学习

狂刀 · 发表于 2005-10-6 04:46:35

还算不上完美，当多义线最后一点与起始点距离很近（阈值范围内）甚至重合但又没有闭合（dxf70=0）的情况下，没有能自动处理成闭合（应再少一个顶点）。
提供一个程序作比较
http://p4.xdcad.net/forum/showth ... 2292292#post2292292

eachy · 发表于 2005-10-6 08:47:50

;;

(defun lwpl-remove-duppoint
(e / a a1 b b1 c c1 en j n new p p1 key new1)
(setq en (entget e))
(while (setq n (car en))
(if (= (car n) 90)
(setq j (cdr n))
)
(if (= (car n) 10)
(progn
(mapcar 'set '(p a b c) en)
(setq en (cddddr en)
key t
) ;_key进入dxf10
(if (equal p1 p 1e-4)
(setq j (1- j))
(if p1
(setq new (append new (list p1 a1 b1 c1)))
)
)
(mapcar 'set '(p1 a1 b1 c1) (list p a b c))
) ;_progn
(progn (if key
(setq new (append new (list p1 a1 b1 c1))
key nil
) ;_dxf10读完了.
)
(setq new (append new (list n))
en (cdr en)
)
)
) ;_if
) ;_while
(if (equal (assoc 10 new)
(assoc 10 (setq new1 (reverse new)))
0.000001
)
(setq new (reverse
(cdr (member (assoc 10 new1) new1)) ;_去掉了 210 ?
)
new (subst (cons 70 (1+ (cdr (assoc 70 new))))
(assoc 70 new)
new
)
j (1- j)
)
)
(entmod (subst (cons 90 j) (assoc 90 new) new))
)

(defun lwpl-remove-duppoint 
       (e / a a1 b b1 c c1 en j n new p p1 key new1) 
  (setq en (entget e)) 
  (while (setq n (car en)) 
    (if        (= (car n) 90) 
      (setq j (cdr n)) 
    ) 
    (if        (= (car n) 10) 
      (progn 
        (mapcar 'set '(p a b c) en) 
        (setq en  (cddddr en) 
              key t 
        ) ;_key进入dxf10 
        (if (equal p1 p 1e-4) 
          (setq j (1- j)) 
          (if p1 
            (setq new (append new (list p1 a1 b1 c1))) 
          ) 
        ) 
        (mapcar 'set '(p1 a1 b1 c1) (list p a b c)) 
      ) ;_progn 
      (progn (if key 
               (setq new (append new (list p1 a1 b1 c1)) 
                     key nil 
               ) ;_dxf10读完了. 
             ) 
             (setq new (append new (list n)) 
                   en  (cdr en) 
             ) 
      ) 
    ) ;_if 
  ) ;_while 
  (if (equal (assoc 10 new) 
             (assoc 10 (setq new1 (reverse new))) 
             0.000001 
      ) 
    (setq new (reverse 
                (cdr (member (assoc 10 new1) new1)) ;_去掉了 210 ? 
              ) 
          new (subst (cons 70 (1+ (cdr (assoc 70 new)))) 
                     (assoc 70 new) 
                     new 
              ) 
          j   (1- j) 
    ) 
  ) 
  (entmod (subst (cons 90 j) (assoc 90 new) new)) 
)

lhg · 发表于 2005-10-9 19:33:36

用在那种情况？

afeng0712 · 发表于 2005-10-11 12:46:17

如果是任意曲线应该如何处理呢？

eachy · 发表于 2005-10-12 00:26:30

最初由 afeng0712 发布
[B]如果是任意曲线应该如何处理呢？ [/B]

什么叫任意曲线？CAD中的Curve包括：Line、Arc、Circle、Spline、Ellipse、Polyline、Lwpolyline，可能产生重合点的只有Polyline、Lwpolyline、Spline

hndwl · 发表于 2005-11-21 00:17:38

Polyline重复点如何删除呢,我的程序只能查找

lihy203 · 发表于 2009-3-25 18:07:16

学习

lukern · 发表于 2009-5-15 11:00:58

polyline重复点的删除稍微麻烦些,因为其顶点坐标用一个vertex子实体来管理的,可以用一种办法来实现:即用一个自定义函数来提取所有顶点,组成一个列表,用上面的算法来找出重复点并从列表中去掉,再根据这些顶点重新生成多义线,同时将原有polyline线删除.

lrhui · 发表于 2009-6-10 10:03:38

学习学习!

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

[LISP函数]：LWPOLYLINE消重(函数)

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

相关帖子