设为首页收藏本站转
发帖领奖家园QQ群申请版主版主评价切换到宽版

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › A/VLISP › [原创]：判断两复线是否一致(支持颜色,线形)删除重复顶 ...
12下一页
返回列表 发新帖
查看: 1685|回复: 19

[原创]：判断两复线是否一致(支持颜色,线形)删除重复顶点,顶点列表可不一致..

[复制链接]
舟自横
发表于 2005-9-27 20:42:10 | 显示全部楼层 |阅读模式
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略

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

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

×
判断复线相同的程序改进
:只要两复线完全重合即判为相同
[PHP]
(defun hy_samepoly(en1 en2 incolor inlayer width ltype / en10getl en42getl i out outto);;?t nil
   (hy_delcfvetex en1) (hy_delcfvetex en2);;先删除重复顶点在做比较
   (setq en10getl (massoc 10 (entget en2))
         en42getl (massoc 42 (entget en2)))
   (setq i 0)
   (setq out niL)
   (if (= (length (massoc 10 (entget en1))) (length en10getl))
     (progn
   (while (< i (length en10getl))
   (if (or (and (equal (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               (massoc 10 (entget en1)) (append (cdr (massoc 10 (entget en1)))
                                                (list (car (massoc 10 (entget en1))))))
     (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               en10getl (append (cdr en10getl)
                                                (list (car en10getl)))) 0.000001)
            (equal (massoc 42 (entget en1)) en42getl 0.000001)
            )
(and (equal (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               (massoc 10 (entget en1)) (append (cdr (massoc 10 (entget en1)))
                                                (list (car (massoc 10 (entget en1))))))
     (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               (reverse en10getl) (append (cdr (reverse en10getl))
                                                (list (car (reverse en10getl))))) 0.000001)
            (equal (massoc 42 (entget en1)) (reverse en42getl) 0.000001)
            )
)
     (setq out "it'ok"))
     (setq en10getl (append (cdr en10getl) (list (car en10getl)))
           en42getl (append (cdr en42getl) (list (car en42getl)))
           )
     (setq i (1+ i))
     )
   (setq outto t)
   (if (= "it'ok" out)
     (progn
       (if incolor (if (/= (vla-get-color (vlax-ename->vla-object en1))
                          (vla-get-color (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       (if inlayer (if (/= (vla-get-layer (vlax-ename->vla-object en1))
                          (vla-get-layer (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       (if width (if (/= (vla-get-ConstantWidth (vlax-ename->vla-object en1))
                          (vla-get-ConstantWidth (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       (if ltype (if (/= (vla-get-Linetype (vlax-ename->vla-object en1))
                          (vla-get-Linetype (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       )
     (setq outto nil)
     )
   )
   (setq outto nil)
     )
   outto
   )
(defun hy_addnth(new n oldlist / alist blist);;在指定位置插入项
  (setq alist nil)
  (setq i 0)
  (repeat n
    (setq alist (cons (nth i oldlist) alist))
    (setq i (1+ i))
    )
  (setq alist (reverse alist))
  (setq i n)
  (setq blist nil)
  (repeat (- (length oldlist) n)
    (setq blist (cons (nth i oldlist) blist))
    (setq i (1+ i))
    )
  (setq blist (reverse blist))
  (append alist (list new) blist)
  )
(defun hy_delcfvetex(en / o1list o1listx pos);;删除重复顶点
  (if (setq o1list (hy_listdoublep (entget en) t))
     (progn (foreach item o1list (if (= (car item) 10)
                              (progn (setq pos (vl-position item (entget en)))
                                     (setq o1listx (hy_addnth item pos (vl-remove item (entget en))))
                                )
                            )
       )
       (entmod o1listx)
     )
     )
  )

(defun hy_listdoublep(lip do / u item nlist);;判断列表重复项
  (if (/= lip nil)
    (progn
   (setq nlist nil)
  (setq u 0)
  (repeat (length lip)
    (setq item (nth u lip))
    (if (< (length(vl-remove item lip))
           (- (length lip) 1)
           )
        (setq nlist (cons item nlist))
      )
    (setq u (1+ u))
    )
    (if do (hy_erasedouble (reverse nlist))
      (reverse nlist))
    )
  )
  )
(defun hy_erasedouble(nlist / needlist);;;?删除表重复项保留一项
  (setq needlist nlist)
  (foreach item nlist (setq needlist (append (list item) (vl-remove item needlist)))
    )
  (reverse needlist))
[/PHP]
setq, en10getl, entget

相关帖子

论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复

使用道具 举报

啵浪鼓
发表于 2005-9-27 20:52:36 | 显示全部楼层
老弟：
我现在上海工作，你还在中山吗？你想到这来工作吗？现我们这里招一个设计，如果你愿意来将是组长以上职位，想来近期内给我电话：13818973792

顺便将俺下面这个删除重复线的程序整好，目前问题是只能删除LINE，ARE，CIRCLE，TEXT，我想要增加一个删除重复LWPOLYLINE的功能，但不能破坏原来的组合
(如果能做到跟CAD2005  ET工具内的overkill带对话框功能当然最好)
[php]

(DEFUN C:WE (/ Pp p3 cn p1 ppc ppa
PPC ent_erase REL RELL RELN ent_ref ent_rep SUBENT ent_com  ENTPFf2
minp maxp lenl1  lenl2  lenx1 lenx2 lenY1 lenY2 maxlen ENTPp1 ENTPp2 ENTPF1
ENTPF2 MINA MAXA pps en ppl ENTPfF1)
(princ "Kill overlap 【ARC,CIRCLE,LINE,TEXT】")
(setq m:err *error* *error* *merr*)
(setvar "cmdecho" 0)
(SETQ Ppa (SSGET '(      (-4 . "<OR")
                         (0 . "ARC")
                         (0 . "LINE")
                         (0 . "TEXT")
                         (0 . "CIRCLE")
                         (-4 . "OR>")
)))
(if Ppa
(progn
(command"ucs" "w")
(setq cn 0)
(setvar"osmode" 0)
(setq con 0 ent_erase(ssadd) relp 0)
(SETQ Pps (SSGET "p"))
(if pps
(repeat 4
(setq ppc pps rel (sslength pps))
(command"select" pps "")
(cond ((= con 2)(setq ppc (SSGET "p" '((0 . "CIRCLE"))))
        (if ppc
        (progn
        (setq rel (sslength ppc) rell 0)
                (repeat rel
        (setq ent_ref (ssname ppc rell))
        (SETQ        ENTPF1 (cdr (assoc 10 (entget ent_ref)))
                ENTPF2 (cdr (assoc 40 (entget ent_ref))))
        (command"select" pps "")
(setq ppl (SSGET "p" (list(cons 0 "CIRCLE")(cons 10 ENTPF1)(cons 40 ENTPF2))))
        (setq reln 0 rell(1+ rell)relp(1+ relp))
        (if ppl(repeat (-(sslength ppl)1)
                (setq ent_rep (ssname ppl reln))
                        (setq ent_erase(ssadd ent_rep ent_erase))
        (setq reln (1+ reln))
        ))
        (MAPCAR 'PRINC(list "\rComplete modify and delete repeadted entity "
                        (rtos(/ (* relp 100.0) (sslength pps))2 1)"%!:CIRCLE\t\t"))
                )))
        )
        ((= con 1)(setq ppc (SSGET "p" '((0 . "ARC"))))
        (if ppc
        (progn
        (setq rel (sslength ppc) rell 0 )
                (repeat rel
        (setq ent_rep (ssname ppc rell)relp (1+ relp))
        (SETQ        ENTPFf1 (cdr (assoc 10 (entget ent_rep)))
                ENTPFf2 (cdr (assoc 40 (entget ent_rep))))
                        (command "select" ppc "")
     (setq ent_com(ssget "p" (list(cons 10 entpff1)(cons 40 entpff2))))
        (setq reln 0 rell(1+ rell))
        (repeat (- rel rell reln)
                (setq ent_ref (ssname ppc (+ reln rell)))
                        (if ent_com
                        (if (ssdel ent_ref ent_com)
                                (progn
                        (SETQ        ENTPF1 (cdr (assoc 50 (entget ent_ref)))
                                ENTPF2 (cdr (assoc 51 (entget ent_ref))))
                        (SETQ        ENTPP1 (cdr (assoc 50 (entget ent_rep)))
                                ENTPP2 (cdr (assoc 51 (entget ent_rep))))
                        (cond ((and(>= ENTPF1 ENTPF2)(>= ENTPp1 ENTPp2))
                                (SETQ ENTPF2(+ ENTPF2 (* PI 2)))
                                (SETQ ENTPp2(+ ENTPp2 (* PI 2))))
                        ((and(>= ENTPp1 ENTPp2)(<= ENTPF1 ENTPF2))
                                (SETQ ENTPp2(+ ENTPp2 (* PI 2)))
                                (if(> ENTPp1 ENTPf2)
                                (progn(SETQ ENTPf2(+ ENTPf2 (* PI 2)))
                                (SETQ ENTPf1(+ ENTPf1 (* PI 2))))))
                        ((and(>= ENTPf1 ENTPf2)(<= ENTpp1 ENTPp2))
                                (SETQ ENTPf2(+ ENTPf2 (* PI 2)))
                                (if(> ENTPf1 ENTPp2)
                                (progn(SETQ ENTPp1(+ ENTPp1 (* PI 2)))
                                (SETQ ENTPp2(+ ENTPp2 (* PI 2))))))
                        )
                        (IF        (OR        (AND(<= ENTPF1 ENTPP2)(>= ENTPF2 ENTPP1))
                                        (AND(<= ENTPp1 ENTPf2)(>= ENTPp2 ENTPf1))
                                        (AND(>= ENTPp1 ENTPf1)(<= ENTPp2 ENTPf2))
                                        (AND(>= ENTPf1 ENTPp1)(<= ENTPf2 ENTPp2)))
                        (PROGN
                        (SETQ MINA(MIN ENTPF1 ENTPP1 ENTPF2 ENTPP2))
                        (SETQ MAXA(MAX ENTPF2 ENTPP2 ENTPF1 ENTPP1))
                        (if        (or(<(- MAXA MINA)(- ENTPp2 ENTPp1))
                                (<(- MAXA MINA)(- ENTPf2 ENTPf1)))
                                (princ)
                        (progn
                                (IF(> MAXA (* 2 PI))(SETQ MAXA(- MAXA (* 2 PI))))
                        (SETQ SUBENT(SUBST (CONS 50 MINA)
                                (assoc 50 (entget ent_ref))(entget ent_ref)))
                        (ENTMOD SUBENT)
                        (SETQ SUBENT(SUBST (CONS 51 MAXA)
                                (assoc 51(entget ent_ref))(entget ent_ref)))
                        (ENTMOD SUBENT)(ENTUPD ent_ref)
                                ))
                        (setq ent_erase(ssadd ent_rep ent_erase))
                                ))
                        )))
        (setq reln (1+ reln))
        )
        (MAPCAR 'PRINC(list "\rComplete modify and delete repeadted entity "
                        (rtos(/ (* relp 100.0) (sslength pps))2 1)"%!:ARC\t\t"))
                )))
        )
        ((= con 0)(setq ppc (SSGET "p" '((0 . "LINE"))))
        (if ppc
        (progn
        (setq rel (sslength ppc) rell 0 )
                (repeat rel
        (setq ent_rep (ssname ppc rell))
                        (SETQ        ENTPF1 (cdr (assoc 10 (entget ent_rep)))
                                ENTPF2 (cdr (assoc 11 (entget ent_rep))))
        (setq reln 0 rell(1+ rell)relp (1+ relp))
        (repeat (- rel rell reln)
                (setq ent_ref (ssname ppc (+ reln rell)))
                        (SETQ        ENTPP1 (cdr (assoc 10 (entget ent_ref)))
                                ENTPP2 (cdr (assoc 11 (entget ent_ref))))
                        (IF(NULL(INTERS ENTPF1 ENTPF2 ENTPP1 ENTPP2 nil))
                                (IF(OR(and(null(INTERS ENTPF2 ENTPP1 ENTPF1 ENTPP2))
                                        (null(INTERS ENTPF2 ENTPP2 ENTPF1 ENTPP1)))
                                (<(distance ENTPp2 ENTPF2)0.00001)
                                (<(distance ENTPp1 ENTPF2)0.00001)
                                (<(distance ENTPp1 ENTPf1)0.00001)
                                (<(distance ENTPf1 ENTPP2)0.00001))
                        (PROGN
                (setq lenl1(distance entpf1 entpf2))
                (setq lenl2(distance entpp1 entpp2))
                (setq lenx1(distance entpf1 entpp1))
                (setq lenx2(distance entpf1 entpp2))
                (setq leny1(distance entpf2 entpp1))
                (setq leny2(distance entpf2 entpp2))
                (setq maxlen(max lenl1 lenl2 lenx1 lenx2 leny1 leny2))
                (if (<= maxlen (+ lenl1 lenl2))(progn
                (cond   ((= lenl1 maxlen)(setq minp entpf1 maxp entpf2))
                        ((= lenl2 maxlen)(setq minp entpp1 maxp entpp2))
                        ((= lenx1 maxlen)(setq minp entpf1 maxp entpp1))
                        ((= lenx2 maxlen)(setq minp entpf1 maxp entpp2))
                        ((= leny1 maxlen)(setq minp entpf2 maxp entpp1))
                        ((= leny2 maxlen)(setq minp entpf2 maxp entpp2))
                )
                        (SETQ SUBENT(SUBST (CONS 10  minp)
                                (assoc 10 (entget ent_ref))(entget ent_ref)))
                        (ENTMOD SUBENT)
                        (SETQ SUBENT(SUBST (CONS 11  maxp)
                                (assoc 11(entget ent_ref))(entget ent_ref)))
                        (ENTMOD SUBENT)(ENTUPD ent_ref)
                        (setq ent_erase(ssadd ent_rep ent_erase))
                        )))))
        (setq reln (1+ reln))
        )
        (MAPCAR 'PRINC(list "\rComplete modify and delete repeadted entity "
                        (rtos(/ (* relp 100.0) (sslength pps))2 1)"%!:LINE\t\t"))
                )))
        )
        ((= con 3)(setq ppc (SSGET "p" '((0 . "TEXT"))))
        (if ppc
        (progn
        (setq rel (sslength ppc) rell 0 )
                (repeat rel
        (setq ent_ref (ssname ppc rell))
        (SETQ        ENTPF1 (cdr (assoc 1 (entget ent_ref))))
        (SETQ        ENTPF2 (cdr (assoc 10 (entget ent_ref))))
        (command"select" pps "")
        (setq ppl (SSGET "p" (list(cons 0 "text")(cons 1 ENTPF1)(cons 10 ENTPF2))))
        (setq reln 0 rell(1+ rell)relp (1+ relp))
        (if ppl(repeat (- (sslength ppl)1)
                (setq ent_rep (ssname ppl reln))
                        (setq ent_erase(ssadd ent_rep ent_erase))
        (setq reln (1+ reln))
        ))
        (MAPCAR 'PRINC(list "\rComplete modify and delete repeadted entity "
                        (rtos(/ (* relp 100.0) (sslength pps))2 1)"%!:TEXT\t\t"))
                )))
        )
)
(setq con (1+ con))
))
(IF ent_erase
(progn(command "erase" ent_erase "")
(IF (>(SSLENGTH ENT_ERASE) 1)
(PROGN
(mapcar 'princ(list "\nThere were "
(SSLENGTH  ENT_ERASE)
" ARC or CIRCLE or LINE or TEXT to be delete!")))
(PROGN(IF(=(SSLENGTH ENT_ERASE) 1)
(mapcar 'princ(list "\nThere was "
(SSLENGTH  ENT_ERASE)
" ARC or CIRCLE or LINE or TEXT to be delete!"))
))))
)
)
)
(setq *error* m:err m:err nil)
(setvar "osmode" 39)
(princ))[/php]
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

狂刀
发表于 2005-9-28 12:50:02 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
我们大家也可以给你打电话么？

1楼麻烦解释一下参数以便测试，或举个例子
或附上一个测试程序

另外
错误: no function definition: MASSOC
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

它山之石
发表于 2005-9-28 12:56:01 | 显示全部楼层
最初由 狂刀 发布
[B]我们大家也可以给你打电话么？ [/B]


既然都公开招聘了，打个电话应该可以的吧。
只是不知能给个什么职位。呵呵
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

狂刀
发表于 2005-9-28 20:08:41 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
舟兄可以作个组长，我可不可以作个打字员什么的？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

舟自横
 楼主| 发表于 2005-9-28 20:17:00 | 显示全部楼层
呵呵..狂刀兄真会开玩笑..也很喜欢凑热闹..
我和二楼兄弟原来是同事拉..好朋友来的..
要是刀兄有兴趣怎么也弄个经理当当什么的..呵呵..
(defun massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
      )
    )
  (reverse nlist))
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

狂刀
发表于 2005-9-29 07:41:54 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
有转角的是不是认为不等？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

舟自横
 楼主| 发表于 2005-9-29 08:02:45 | 显示全部楼层
你指的转角是什么啊?
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

啵浪鼓
发表于 2005-10-6 09:48:26 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
咦，二楼的程序没帮我处理？？？
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

狂刀
发表于 2005-10-6 17:52:19 | 显示全部楼层
舟兄弟啊，不行啊，发现如下问题：
１。程序对假闭合情况没有处理，即终点与起点重合，但是属性不是闭合的，此时外形是一样的。
２。程序会修改原有多义线，对假闭合的多义线会裁减掉最后一段。
３。程序ｔｔ２出现异常错误：
命令: tt2
选择对象: 指定对角点: 找到 2 个
选择对象:
错误: Automation 错误。 输入无效


附我的测试程序：

  3.   [FONT=courier new](defun c:tt ( / ss)
  4.   (command ".undo" "be")
  5.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
  6.   (hy_samepoly (ssname ss 0)(ssname ss 1) nil nil nil nil)
  7.   (command ".undo" "e")
  8. )
  9. (defun c:tt2 ( / ss)
  10.   (command ".undo" "be")
  11.   (setq ss (ssget '((0 . "LWPOLYLINE"))))
  12.   (hy_samepoly (ssname ss 0)(ssname ss 1)T T T T)
  13.   (command ".undo" "e")
  14. )
  15.   [/FONT]


再附我的测试图：
６个多义线都“外形一样”。两两拷贝到一起来判断，但是c:tt　c:tt2 都不能正确判断。
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

狂刀
发表于 2005-10-6 17:52:56 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
a
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

舟自横
 楼主| 发表于 2005-10-6 20:15:01 | 显示全部楼层
[php]
(defun hy_samepoly(en1 en2 incolor inlayer width ltype / en10getl en42getl i out outto);;?耞ㄢ確絬琌??璓 t nil
   (hy_delcfvetex en1 0.0001) (hy_delcfvetex en2 0.0001)
   (setq en10getl (massoc 10 (entget en2))
         en42getl (massoc 42 (entget en2)))
   (setq i 0)
   (setq out niL)
   (if (= (length (massoc 10 (entget en1))) (length en10getl))
     (progn
   (while (< i (length en10getl))
   (if (or (and (equal (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               (massoc 10 (entget en1)) (append (cdr (massoc 10 (entget en1)))
                                                (list (car (massoc 10 (entget en1))))))
     (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               en10getl (append (cdr en10getl)
                                                (list (car en10getl)))) 0.000001)
            (equal (massoc 42 (entget en1)) en42getl 0.000001)
            )
(and (equal (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               (massoc 10 (entget en1)) (append (cdr (massoc 10 (entget en1)))
                                                (list (car (massoc 10 (entget en1))))))
     (mapcar '(lambda(x y) (list (- (car y) (car x)) (- (cadr y) (cadr x))))
               (reverse en10getl) (append (cdr (reverse en10getl))
                                                (list (car (reverse en10getl))))) 0.000001)
            (equal (massoc 42 (entget en1)) (reverse en42getl) 0.000001)
            )
)
     (setq out "it'ok"))
     (setq en10getl (append (cdr en10getl) (list (car en10getl)))
           en42getl (append (cdr en42getl) (list (car en42getl)))
           )
     (setq i (1+ i))
     )
   (setq outto t)
   (if (= "it'ok" out)
     (progn
       (if incolor (if (/= (vla-get-color (vlax-ename->vla-object en1))
                          (vla-get-color (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       (if inlayer (if (/= (vla-get-layer (vlax-ename->vla-object en1))
                          (vla-get-layer (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       (if width (if (/= (vla-get-ConstantWidth (vlax-ename->vla-object en1))
                          (vla-get-ConstantWidth (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       (if ltype (if (/= (vla-get-Linetype (vlax-ename->vla-object en1))
                          (vla-get-Linetype (vlax-ename->vla-object en2)))
                     t (setq outto nil)))
       )
     (setq outto nil)
     )
   )
   (setq outto nil)
     )
   outto
   )
(defun hy_delcfvetex (e preci  / 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 preci)
          (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 massoc (key alist / x nlist)
  (foreach x alist
    (if (eq key (car x))
      (setq nlist (cons (cdr x) nlist))
      )
    )
  (reverse nlist))
[/php]
重新测试你的图档已经测试应该没有问题了
因为我需要检查的是封闭复线所以对不封闭复线不加考虑
如果到兄有兴趣可以帮我完善啊..呵呵
另回李兄...最近在忙写一个删除复线多余顶点的程序所以没有看你那个..你哪个消重的程序用ET的还不够吗?如果你实在需要等几天有时间了我试一下看吧..
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

eachy

已领礼包: 593个

财富等级: 财运亨通
发表于 2005-10-6 22:44:40 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
既用向量就彻底点

  3. (defun hy_samepoly (en1           en2          incolor        inlayer              width
  4.                     ltype  /          el1         el2        pts1   pts2   pv1
  5.                     B1           B2          pv2         tf
  6.                    )
  7.   (defun getptsvec (pts)
  8.     (mapcar '(lambda (a b) (mapcar '- a b))
  9.             (cdr pts)
  10.             (reverse (cdr (reverse pts)))
  11.     )
  12.   )
  13.   (defun lst-n (lst n / m nl)
  14.     (setq m 0)
  15.     (while (< m n)
  16.       (setq nl (cons (car lst) nl))
  17.       (setq lst        (cdr lst)
  18.             m        (1+ m)
  19.       )
  20.     )
  21.     (append lst (reverse nl))
  22.   )
  23.   (defun last! (l) (reverse (cdr (reverse l)))
  24.   ;;?耞ㄢ確絬琌??@璓 t nil
  25.   (hy_delcfvetex en1 0.0001)
  26.   (hy_delcfvetex en2 0.0001)
  27.   (setq        el1 (entget en1)
  28.         el2 (entget en2)
  29.   )
  30.   (if (equal (assoc 90 el1) (assoc 90 el2)) ;_顶点数首先要相同
  31.     (progn
  32.       (setq pts1 (massoc 10 el1)
  33.             pts2 (massoc 10 el2)
  34.             pv1         (getptsvec pts1)
  35.             pv2         (getptsvec pts2)
  36.       )
  37.       (if
  38.         (setq
  39.           tf (vl-every
  40.                '(lambda (x) x)
  41.                (mapcar
  42.                  '(lambda (x)
  43.                     (if        (or (vl-position x pv2)
  44.                             (vl-position (mapcar '- x) pv2)
  45.                         )
  46.                       t
  47.                       nil
  48.                     )
  49.                   )
  50.                  pv1
  51.                )
  52.              )
  53.         )
  54.          (progn
  55.            (setq b1 (massoc 42 el1)
  56.                  b2 (massoc 42 el2)
  57.                  b2 (lst-n b1 (vl-position (car pts2) pts1))
  58.            )
  59.            (setq tf (or        (equal b1 b2 0.0000001)
  60.                         (equal b1 (cons (last b2) (last! b2)))
  61.                         0.0000001
  62.                     )
  63.            )
  64.            (if tf
  65.              (progn
  66.                (if incolor
  67.                  (if (/= (vla-get-color (vlax-ename->vla-object en1))
  68.                          (vla-get-color (vlax-ename->vla-object en2))
  69.                      )
  70.                    t
  71.                    (setq tf nil)
  72.                  )
  73.                )
  74.                (if inlayer
  75.                  (if (/= (vla-get-layer (vlax-ename->vla-object en1))
  76.                          (vla-get-layer (vlax-ename->vla-object en2))
  77.                      )
  78.                    t
  79.                    (setq tf nil)
  80.                  )
  81.                )
  82.                (if width
  83.                  (if
  84.                    (/=
  85.                      (vla-get-ConstantWidth (vlax-ename->vla-object en1))
  86.                      (vla-get-ConstantWidth (vlax-ename->vla-object en2))
  87.                    )
  88.                     t
  89.                     (setq tf nil)
  90.                  )
  91.                )
  92.                (if ltype
  93.                  (if (/= (vla-get-Linetype (vlax-ename->vla-object en1))
  94.                          (vla-get-Linetype (vlax-ename->vla-object en2))
  95.                      )
  96.                    t
  97.                    (setq tf nil)
  98.                  )
  99.                )
  100.              )
  101.            )
  102.          )
  103.       )
  104.     )
  105.   )
  106.   tf
  107. )
  108. (defun hy_delcfvetex (e preci / a a1 b b1 c c1 en j n new p p1 key)
  109.   (setq en (entget e))
  110.   (while (setq n (car en))
  111.     (if        (= (car n) 90)
  112.       (setq j (cdr n))
  113.     )
  114.     (if        (= (car n) 10)
  115.       (progn
  116.         (mapcar 'set '(p a b c) en)
  117.         (setq en  (cddddr en)
  118.               key t
  119.         ) ;_key??dxf10
  120.         (if (equal p1 p preci)
  121.           (setq j (1- j))
  122.           (if p1
  123.             (setq new (append new (list p1 a1 b1 c1)))
  124.           )
  125.         )
  126.         (mapcar 'set '(p1 a1 b1 c1) (list p a b c))
  127.       ) ;_progn
  128.       (progn (if key
  129.                (setq new (append new (list p1 a1 b1 c1))
  130.                      key nil
  131.                ) ;_dxf10Ч?.
  132.              )
  133.              (setq new (append new (list n))
  134.                    en  (cdr en)
  135.              )
  136.       )
  137.     ) ;_if
  138.   ) ;_while
  139.   ;;============================================================
  140.   (if (equal (assoc 10 new)
  141.              (assoc 10 (setq new1 (reverse new)))
  142.              preci
  143.       )
  144.     (setq new (reverse
  145.                 (cdr (member (assoc 10 new1) new1)) ;_去掉了 210 ?
  146.               )
  147.           new (subst (cons 70 (1+ (cdr (assoc 70 new))))
  148.                      (assoc 70 new)
  149.                      new
  150.               )
  151.           j   (1- j)
  152.     )
  153.   )
  154.   (entmod (subst (cons 90 j) (assoc 90 new) new))
  155. )
  156. (defun massoc (key alist / x nlist)
  157.   (foreach x alist
  158.     (if        (eq key (car x))
  159.       (setq nlist (cons (cdr x) nlist))
  160.     )
  161.   )
  162.   (reverse nlist)
  163. )
  164. (defun c:tt (/ e1 e2)
  165.   (if (and (setq e1 (car (entsel)))
  166.            (setq e2 (car (entsel)))
  167.       )
  168.     (hy_samepoly e1 e2 nil nil nil nil)
  169.   )
  170. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

aeo

已领礼包: 488个

财富等级: 日进斗金
发表于 2005-10-7 01:01:38 | 显示全部楼层
没仔细看
我想：两个点，要判断两次
      四个点要八次吧.


我的设想:
闭合线: 顶点数相同的情况下，取第一根线的特殊点，根据点位求在第二线上的信息，如果一圈下来一样，就相同.
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

舟自横
 楼主| 发表于 2005-10-7 08:32:45 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
呵呵..大家的反响还是很激烈的..其实我想这个问题应该还有其他简单解决的办法..
以前好象见过一个类似的函数是用纯AUTOLISP写的..好象速度还可以..我写的哪个就是嫌他速度慢...哎过一段时间再重新考虑过..看是不是有更快更好的方法..
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2025-9-28 15:57 , Processed in 0.209859 second(s), 61 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2025 Discuz! Team.

快速回复 返回顶部 返回列表