删除重复块高程--修改明经某位大侠程序

树櫴希德

2. 
   
3. ;选择集与对象名表互转
   
4. (defun cx-ss2en
   
5.   (ss / enlst)
   
6.   (cond
   
7.     ((= (type ss) 'PICKSET)
   
8.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
   
9.     )
   
10.     ((= (type ss) 'LIST)
    
11.       (setq enlst (ssadd))
    
12.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
    
13.     )
    
14.     ((='ename(type ss))
    
15.       (ssadd ss)
    
16.     )
    
17.   )
    
18. )
    
19. 
    
20. 
    
21. 
    
22. 
    
23. 
    
24. ;货物分两组（样品 库存）
    
25. (defun lst->2lst(lst / lst1 lst2)
    
26.   (setq lst1 '() lst2 '())
    
27. (foreach a lst
    
28.     (if (member a lst2)
    
29.       (setq lst1 (cons a lst1))
    
30.       (setq lst2 (cons a lst2))
    
31.     )
    
32.   )
    
33. (cons (reverse lst2) (reverse lst1))
    
34. )
    
35. ;检查重叠块
    
36. (defun c:chk_blocks (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)
    
37.   (setq ss (ssget '((0 . "insert")))
    
38.        i  0
    
39.        )
    
40.   (if (and ss (> (sslength ss) 2))
    
41.    (progn
    
42.     (setq entlst (cx-ss2en ss)
    
43.           ptlst (mapcar '(lambda(x) (assoc 10(entget x))) entlst)
    
44.           2ptlst (lst->2lst ptlst)
    
45.           )
    
46.      (if (cdr 2ptlst)
    
47.        (progn
    
48.          ;(setq pt (getpoint "引出点："))
    
49.          (foreach x (cdr 2ptlst)
    
50.            ;(entmake (list '(0 . "line") '(8 . "0-辅助层tem") (cons 62 1) x (cons 11 pt)))
    
51. (repeat (setq k (length (cdr 2ptlst)))
    
52.     (if  (and (setq e (ssname ss (setq k (1- k ))))
    
53.        (setq en (entget e))
    
54.   )
    
55.       (progn  
    
56.   
    
57.   (if (member x en)
    
58.     (entdel e)
    
59.     ;(setq en (cons x en))
    
60.   )
    
61.       )
    
62.     )
    
63.   )
    
64. 
    
65. 
    
66.            
    
67.            
    
68.            )
    
69.          )
    
70.          (alert "报告老大，没有找到重叠块！")
    
71.      )
    
72.     )
    
73.     (alert "老大，这么简单的问题自己解决！")
    
74.    )
    
75.    (princ)
    
76. )
    
77. 
    
78. 
    
79. 
    
80. ;;156.1 [功能] 删除重叠对象(overkill)
    
81. ;;不知谁写的,太好了.
    
82. (DEFUN HH:delBLOCKs (ss / E EN K LIST1 S9 XY)
    
83.   (repeat (setq k (sslength ss))
    
84.     (if  (and (setq e (ssname ss (setq k (1- k ))))
    
85.        (setq en (entget e))
    
86.   )
    
87.       (progn  
    
88.   (setq xy (cdr en))
    
89.   (IF (SETQ S9 (ASSOC 5 XY))
    
90.     (SETQ XY (subst '(5 . "ASD") S9 XY))
    
91.   )
    
92.   (if (member xy list1)
    
93.     (entdel e)
    
94.     (setq list1 (cons xy list1))
    
95.   )
    
96.       )
    
97.     )
    
98.   )
    
99. )

<br /> ;选择集与对象名表互转<br /> (defun cx-ss2en<br />   (ss / enlst)<br />   (cond<br />     ((= (type ss) 'PICKSET)<br />       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))<br />     )<br />     ((= (type ss) 'LIST)<br />       (setq enlst (ssadd))<br />       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))<br />     )<br />     ((='ename(type ss))<br />       (ssadd ss)<br />     )<br />   )<br /> )<br /> <br /> <br /> <br /> <br /> <br /> ;货物分两组（样品 库存）<br /> (defun lst->2lst(lst / lst1 lst2)<br />   (setq lst1 '() lst2 '())<br /> (foreach a lst<br />     (if (member a lst2)<br />       (setq lst1 (cons a lst1))<br />       (setq lst2 (cons a lst2))<br />     )<br />   )<br /> (cons (reverse lst2) (reverse lst1))<br /> )<br /> ;检查重叠块<br /> (defun c:chk_blocks (/ ss pt s1 dxf2 dxf41 dxf50 ss1 i)<br />   (setq ss (ssget '((0 . "insert")))<br />        i  0<br />        )<br />   (if (and ss (> (sslength ss) 2))<br />    (progn<br />     (setq entlst (cx-ss2en ss)<br />           ptlst (mapcar '(lambda(x) (assoc 10(entget x))) entlst)<br />           2ptlst (lst->2lst ptlst)<br />           )<br />      (if (cdr 2ptlst)<br />        (progn<br />          ;(setq pt (getpoint "引出点："))<br />          (foreach x (cdr 2ptlst)<br />            ;(entmake (list '(0 . "line") '(8 . "0-辅助层tem") (cons 62 1) x (cons 11 pt)))<br /> (repeat (setq k (length (cdr 2ptlst)))<br />     (if  (and (setq e (ssname ss (setq k (1- k ))))<br />        (setq en (entget e))<br />   )<br />       (progn  <br />   <br />   (if (member x en)<br />     (entdel e)<br />     ;(setq en (cons x en))<br />   )<br />       )<br />     )<br />   )<br /> <br /> <br />            <br />            <br />            ) <br />          )<br />          (alert "报告老大，没有找到重叠块！")<br />      )<br />     )<br />     (alert "老大，这么简单的问题自己解决！")<br />    )<br />    (princ)<br /> )<br /> <br /> <br /> <br /> ;;156.1 [功能] 删除重叠对象(overkill)<br /> ;;不知谁写的,太好了.<br /> (DEFUN HH:delBLOCKs (ss / E EN K LIST1 S9 XY)<br />   (repeat (setq k (sslength ss))<br />     (if  (and (setq e (ssname ss (setq k (1- k ))))<br />        (setq en (entget e))<br />   )<br />       (progn  <br />   (setq xy (cdr en))<br />   (IF (SETQ S9 (ASSOC 5 XY))<br />     (SETQ XY (subst '(5 . "ASD") S9 XY))<br />   )<br />   (if (member xy list1)<br />     (entdel e)<br />     (setq list1 (cons xy list1))<br />   )<br />       )<br />     )<br />   )<br /> )

lucas_3333

还是写明出处与作者比较好
部分应是来之于77077
http://bbs.mjtd.com/thread-113683-1-1.html

HH开头的函数应该是黄老的