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

 找回密码
 立即注册

QQ登录

只需一步，快速开始

扫一扫，访问微社区

晓东CAD家园-论坛»论坛 › ╃CAD编程开发 › A/VLISP › [LISP函数]：VL-REMOVE
返回列表 发新帖
查看: 936|回复: 3

[LISP函数]：VL-REMOVE

[复制链接]
aaddff
发表于 2003-8-27 19:40:30 | 显示全部楼层 |阅读模式
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略

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

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

×
请教我在用VL-REMOVE函数时不知为什么有时有几个相同的，不能完全remove掉，有时又可以，不稳定不知道是什么原因？
REMOVE, 在用, 时有

相关帖子

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

使用道具 举报

aeo

已领礼包: 488个

财富等级: 日进斗金
发表于 2003-8-28 00:31:05 | 显示全部楼层
把你那个不能完全remove掉的表贴出来.
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能，那里可能会有你要找的答案；
如果你在论坛求助问题，并且已经从坛友或者管理的回复中解决了问题，请把帖子标题加上【已解决】；
如何回报帮助你解决问题的坛友，一个好办法就是给对方加【D豆】，加分不会扣除自己的积分，做一个热心并受欢迎的人！
回复 支持 反对

使用道具 举报

aaddff
 楼主| 发表于 2003-8-28 13:36:24 | 显示全部楼层
【广而告之】积分规则、D豆获取攻略       窝窝空间装扮攻略
(SETQ AUTOSS(SSGET "_W" FMP TOP (LIST (CONS 0 "CIRCLE"))))
  
  (SETQ SSAL(SSLENGTH AUTOSS) AUTOCEN(LIST))
  (WHILE (>= (1- SSAL) 0)
    (SETQ SSAUN(SSNAME AUTOSS (1- SSAL))
          SSAUL(ENTGET SSAUN)
          SSAUC(CDR(ASSOC 10 SSAUL))
          )
    (SETQ AUTOCEN(APPEND AUTOCEN (LIST SSAUC)))
    (SETQ SSAL(1- SSAL))
    )
   
;;;  ---------------------------------------------------------


  (SETQ AUTOCEN(VL-SORT AUTOCEN '(LAMBDA (X Y)(< (CAR X)(CAR Y)))))
;;;  ------------------------------------------
(WHILE (> (LENGTH AUTOCEN) 0)
  (SETQ AUP(NTH 0 AUTOCEN))
  
  
  (SETQ A(SSGET "_W" FMP TOP (LIST (CONS 10 AUP))))

  
;;;  ------------------------------------------

  

  (setq al(sslength a)
        ak 0)

;;;---------------------------------
  (while (>= al 1)
    (if (AND
        (/= (cdr(assoc 0 (entget(ssname a (1- al))))) "ARC")
        (/= (cdr(assoc 0 (entget(ssname a (1- al))))) "CIRCLE")
        )
     (ssdel (ssname a (1- al)) a)
      );if
    (setq al(1- al))
    );while
;;;-------------------------------
  
  (setq al(sslength a)
        aa(list)
        ak 0)
  (repeat al
    (setq aname(ssname a ak)
          alist(entget aname)
          ality(assoc 6 alist)
          acr(assoc 40 alist)
          aty(assoc 0 alist)
          acol(assoc 62 alist)
          )

      (setq aks(ssget "_w" fmp top (list aty acr ))
            aksl(sslength aks)
             )

   
    (SETQ AKSL(SSLENGTH AKS) AKSK 0)
      (repeat aksl
        (setq aa(append aa (list(ssname aks aksk))))
        (setq aksk(1+ aksk))
        );repeat sksl
   
    (SETQ AK(1+ AK))
    );REPEAT  AL

;;;=================================================================

  (setq aal(length aa))
(setq aak 0
      aaj 1
      ss (list)
      )
  (if (/= al 1)
(repeat (1- aal)
  (setq aaid(cdr(assoc 10 (entget(nth aak aa)))))
  (setq sameid(list))
  (repeat (- aal aak 1)
    (setq aaid2(cdr(assoc 10(entget(nth aaj aa)))))
    (if (and (= (rtos (car aaid) 2 6)(rtos (car aaid2) 2 6))
             (= (rtos (cadr aaid) 2 6)(rtos (cadr aaid2) 2 6))
             )
;;;    (if (equal aaid aaid2)
      (setq sameid(append sameid (list aaid2)))
      );if
    (setq aaj(1+ aaj))
    );repeat
  (setq sameid(append sameid (list aaid)))
  (if (= al (length sameid))
    (setq ss(append ss (list aaid)))
    );if
  (setq aak(1+ aak)
        aaj(1+ aak)
        )
  );repeat


  (PROGN
    (SETQ AAK 0 ss(list))
  (REPEAT AAL
    (SETQ AAID(CDR(ASSOC 10 (ENTGET (NTH AAK AA)))))
    (SETQ SS(APPEND SS (LIST AAID)))
    (SETQ AAK(1+ AAK))
    )
    )
  )
;;;---------------------------------------------------
(setq ssl(length ss) sskk 0 SSCEN(LIST))
(repeat ssl
  (setq ssa(ssget "_w" fMp top (list (cons 0 "ARC")(cons 10 (nth sskk ss)))))
  (SETQ Ssc(ssget "_w" fMp top (list (cons 0 "CIRCLE")(cons 10 (nth sskk ss)))))
  (IF (/= SSA NIL)(SETQ SSAL (SSLENGTH SSA))(SETQ SSAL 0))
  (IF (/= SSC NIL)(SETQ SSCL(SSLENGTH SSC))(SETQ SSCL 0))
  (IF (= AL (+ SSAL SSCL))(SETQ SSCEN(APPEND SSCEN (LIST(NTH SSKK SS)))))
  (SETQ SSKK (1+ SSKK))
  )
(SETQ SS SSCEN)

;;;========================================================================

(setq ss(vl-sort ss '(lambda (x y)(< (car x)(car y)))))


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

使用道具 举报

aaddff
 楼主| 发表于 2003-8-28 13:42:24 | 显示全部楼层
(SETQ AUTOSS(SSGET "_W" FMP TOP (LIST (CONS 0 "CIRCLE"))))
  
  (SETQ SSAL(SSLENGTH AUTOSS) AUTOCEN(LIST))
  (WHILE (>= (1- SSAL) 0)
    (SETQ SSAUN(SSNAME AUTOSS (1- SSAL))
          SSAUL(ENTGET SSAUN)
          SSAUC(CDR(ASSOC 10 SSAUL))
          )
    (SETQ AUTOCEN(APPEND AUTOCEN (LIST SSAUC)))
    (SETQ SSAL(1- SSAL))
    )
   
;;;  ---------------------------------------------------------


  (SETQ AUTOCEN(VL-SORT AUTOCEN '(LAMBDA (X Y)(< (CAR X)(CAR Y)))))
;;;  ------------------------------------------
(WHILE (> (LENGTH AUTOCEN) 0)
  (SETQ AUP(NTH 0 AUTOCEN))
  
  
  (SETQ A(SSGET "_W" FMP TOP (LIST (CONS 10 AUP))))

  
;;;  ------------------------------------------

  

  (setq al(sslength a)
        ak 0)

;;;---------------------------------
  (while (>= al 1)
    (if (AND
        (/= (cdr(assoc 0 (entget(ssname a (1- al))))) "ARC")
        (/= (cdr(assoc 0 (entget(ssname a (1- al))))) "CIRCLE")
        )
     (ssdel (ssname a (1- al)) a)
      );if
    (setq al(1- al))
    );while
;;;-------------------------------
  
  (setq al(sslength a)
        aa(list)
        ak 0)
  (repeat al
    (setq aname(ssname a ak)
          alist(entget aname)
          ality(assoc 6 alist)
          acr(assoc 40 alist)
          aty(assoc 0 alist)
          acol(assoc 62 alist)
          )

      (setq aks(ssget "_w" fmp top (list aty acr ))
            aksl(sslength aks)
             )

   
    (SETQ AKSL(SSLENGTH AKS) AKSK 0)
      (repeat aksl
        (setq aa(append aa (list(ssname aks aksk))))
        (setq aksk(1+ aksk))
        );repeat sksl
   
    (SETQ AK(1+ AK))
    );REPEAT  AL

;;;=================================================================

  (setq aal(length aa))
(setq aak 0
      aaj 1
      ss (list)
      )
  (if (/= al 1)
(repeat (1- aal)
  (setq aaid(cdr(assoc 10 (entget(nth aak aa)))))
  (setq sameid(list))
  (repeat (- aal aak 1)
    (setq aaid2(cdr(assoc 10(entget(nth aaj aa)))))
    (if (and (= (rtos (car aaid) 2 6)(rtos (car aaid2) 2 6))
             (= (rtos (cadr aaid) 2 6)(rtos (cadr aaid2) 2 6))
             )
;;;    (if (equal aaid aaid2)
      (setq sameid(append sameid (list aaid2)))
      );if
    (setq aaj(1+ aaj))
    );repeat
  (setq sameid(append sameid (list aaid)))
  (if (= al (length sameid))
    (setq ss(append ss (list aaid)))
    );if
  (setq aak(1+ aak)
        aaj(1+ aak)
        )
  );repeat


  (PROGN
    (SETQ AAK 0 ss(list))
  (REPEAT AAL
    (SETQ AAID(CDR(ASSOC 10 (ENTGET (NTH AAK AA)))))
    (SETQ SS(APPEND SS (LIST AAID)))
    (SETQ AAK(1+ AAK))
    )
    )
  )
;;;---------------------------------------------------
(setq ssl(length ss) sskk 0 SSCEN(LIST))
(repeat ssl
  (setq ssa(ssget "_w" fMp top (list (cons 0 "ARC")(cons 10 (nth sskk ss)))))
  (SETQ Ssc(ssget "_w" fMp top (list (cons 0 "CIRCLE")(cons 10 (nth sskk ss)))))
  (IF (/= SSA NIL)(SETQ SSAL (SSLENGTH SSA))(SETQ SSAL 0))
  (IF (/= SSC NIL)(SETQ SSCL(SSLENGTH SSC))(SETQ SSCL 0))
  (IF (= AL (+ SSAL SSCL))(SETQ SSCEN(APPEND SSCEN (LIST(NTH SSKK SS)))))
  (SETQ SSKK (1+ SSKK))
  )
(SETQ SS SSCEN)

;;;========================================================================

(setq ss(vl-sort ss '(lambda (x y)(< (car x)(car y)))))


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

使用道具 举报

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

本版积分规则

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

GMT+8, 2025-9-26 17:48 , Processed in 0.170973 second(s), 36 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2025 Discuz! Team.

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