方便好用的分堆算法

kkq0305

2. ;利用图元在xy轴方向上的投影进行分堆
   
3. ;适合投影没有交叉的情况
   
4. (defun c:tt ()
   
5.   (setq ss (ssget))
   
6.   (setq  lst
   
7.    (mapcar '(lambda (x)
   
8.         (setq obj (vlax-ename->vla-object x))
   
9.         (vla-getboundingbox obj 'minp 'maxp)
   
10.         (setq
    
11.           maxp (mapcar '* '(1.0 1.0) (vlax-safearray->list maxp))
    
12.         )
    
13.         (setq
    
14.           minp (mapcar '* '(1.0 1.0) (vlax-safearray->list minp))
    
15.         )
    
16.         (list x (car minp) (car maxp) (cadr minp) (cadr maxp))
    
17.       )
    
18.      (vl-remove-if-not
    
19.        '(lambda (x) (= 'ENAME (type x)))
    
20.        (apply 'append (ssnamex ss))
    
21.      )
    
22.    )
    
23.   );获取图元投影信息建立表
    
24.   ;表内元素：图元名 minx maxx miny maxy
    
25.   (setq  flst (lambda (lst key);分堆函数
    
26.          ;lst 对图元投影排序之后的lst
    
27.          ;key t 第一次按照x轴投影分堆 nil 第二次按照y轴投影分堆
    
28.          (if lst
    
29.      (if key
    
30.        (progn
    
31.          (setq nlst   (list (list (caar lst)
    
32.                (cadddr (car lst))
    
33.                (last (car lst))
    
34.          ))
    
35.          maxpx (caddar lst)
    
36.          lst   (cdr lst)
    
37.          )
    
38.          (while (and lst (<= (cadar lst) maxpx))
    
39.            (setq nlst  (cons (list (caar lst)
    
40.                  (cadddr (car lst))
    
41.                  (last (car lst))
    
42.            )
    
43.            nlst
    
44.            )
    
45.            maxpx (max maxpx (caddar lst))
    
46.            lst   (cdr lst)
    
47.            )
    
48.          )
    
49.          (cons nlst (flst lst key))
    
50.        );第一次按照x轴投影分堆  按照x轴投影间隔分表 并去掉表内x信息minx maxx
    
51.        (progn
    
52.          (setq nlst   (list (caar lst))
    
53.          maxpy (caddar lst)
    
54.          lst   (cdr lst)
    
55.          )
    
56.          (while (and lst (<= (cadar lst) maxpy))
    
57.            (setq nlst  (cons (caar lst) nlst)
    
58.            maxpy (max maxpy (caddar lst))
    
59.            lst   (cdr lst)
    
60.            )
    
61.          )
    
62.          (cons nlst (flst lst key))
    
63.        );第二次按照y轴投影分堆 按照y轴投影间隔分表 并去掉表内y信息miny maxy
    
64.      )
    
65.          )
    
66.        )
    
67.   )
    
68.   (setq
    
69.     lst
    
70.      (apply
    
71.        'append
    
72.        (mapcar
    
73.    '(lambda (wlst)
    
74.       (flst (vl-sort wlst '(lambda (a b) (< (cadr a) (cadr b))))
    
75.       nil
    
76.       )
    
77.     )
    
78.    (flst (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b)))) t)
    
79.        )
    
80.      )
    
81.   );分堆完成
    
82.   (mapcar
    
83.     '(lambda (x)
    
84.        (setq pt (apply
    
85.    'append
    
86.    (mapcar
    
87.      '(lambda (ent)
    
88.         (vla-getboundingbox (vlax-ename->vla-object ent) 'minp 'maxp)
    
89.         (list (mapcar '* '(1.0 1.0) (vlax-safearray->list maxp))
    
90.           (mapcar '* '(1.0 1.0) (vlax-safearray->list minp))
    
91.         )
    
92.       )
    
93.      x
    
94.    )
    
95.        ))
    
96.        (setq minp (mapcar '- (apply 'mapcar (cons 'min pt)) '(3. 3.)))
    
97.        (setq maxp (mapcar '+ (apply 'mapcar (cons 'max pt)) '(3. 3.)))
    
98.        (entmake  (list '(0 . "LWPOLYLINE")
    
99.           '(100 . "AcDbEntity")
    
100.           '(100 . "AcDbPolyline")
     
101.           '(90 . 4)
     
102.           '(70 . 1)
     
103.           '(62 . 1)
     
104.           (cons 10 minp)
     
105.           (cons 10 (list (car minp) (cadr maxp)))
     
106.           (cons 10 maxp)
     
107.           (cons 10 (list (car maxp) (cadr minp)))
     
108.     )
     
109.        )
     
110.      )
     
111.     lst
     
112.   );按照分堆成果画出红色矩形框 矩形框偏移3个单位
     
113.   (princ)
     
114. )

;利用图元在xy轴方向上的投影进行分堆<br /> ;适合投影没有交叉的情况<br /> (defun c:tt ()<br />   (setq ss (ssget))<br />   (setq  lst<br />    (mapcar '(lambda (x)<br />         (setq obj (vlax-ename->vla-object x))<br />         (vla-getboundingbox obj 'minp 'maxp)<br />         (setq<br />           maxp (mapcar '* '(1.0 1.0) (vlax-safearray->list maxp))<br />         )<br />         (setq<br />           minp (mapcar '* '(1.0 1.0) (vlax-safearray->list minp))<br />         )<br />         (list x (car minp) (car maxp) (cadr minp) (cadr maxp))<br />       )<br />      (vl-remove-if-not<br />        '(lambda (x) (= 'ENAME (type x)))<br />        (apply 'append (ssnamex ss))<br />      )<br />    )<br />   );获取图元投影信息建立表<br />   ;表内元素：图元名 minx maxx miny maxy<br />   (setq  flst (lambda (lst key);分堆函数<br />          ;lst 对图元投影排序之后的lst<br />          ;key t 第一次按照x轴投影分堆 nil 第二次按照y轴投影分堆<br />          (if lst<br />      (if key<br />        (progn<br />          (setq nlst   (list (list (caar lst)<br />                (cadddr (car lst))<br />                (last (car lst))<br />          ))<br />          maxpx (caddar lst)<br />          lst   (cdr lst)<br />          )<br />          (while (and lst (<= (cadar lst) maxpx))<br />            (setq nlst  (cons (list (caar lst)<br />                  (cadddr (car lst))<br />                  (last (car lst))<br />            )<br />            nlst<br />            )<br />            maxpx (max maxpx (caddar lst))<br />            lst   (cdr lst)<br />            )<br />          )<br />          (cons nlst (flst lst key))<br />        );第一次按照x轴投影分堆  按照x轴投影间隔分表 并去掉表内x信息minx maxx<br />        (progn<br />          (setq nlst   (list (caar lst))<br />          maxpy (caddar lst)<br />          lst   (cdr lst)<br />          )<br />          (while (and lst (<= (cadar lst) maxpy))<br />            (setq nlst  (cons (caar lst) nlst)<br />            maxpy (max maxpy (caddar lst))<br />            lst   (cdr lst)<br />            )<br />          )<br />          (cons nlst (flst lst key))<br />        );第二次按照y轴投影分堆 按照y轴投影间隔分表 并去掉表内y信息miny maxy<br />      )<br />          )<br />        )<br />   )<br />   (setq<br />     lst<br />      (apply<br />        'append<br />        (mapcar<br />    '(lambda (wlst)<br />       (flst (vl-sort wlst '(lambda (a b) (< (cadr a) (cadr b))))<br />       nil<br />       )<br />     )<br />    (flst (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b)))) t)<br />        )<br />      )<br />   );分堆完成<br />   (mapcar<br />     '(lambda (x)<br />        (setq pt (apply<br />    'append<br />    (mapcar<br />      '(lambda (ent)<br />         (vla-getboundingbox (vlax-ename->vla-object ent) 'minp 'maxp)<br />         (list (mapcar '* '(1.0 1.0) (vlax-safearray->list maxp))<br />           (mapcar '* '(1.0 1.0) (vlax-safearray->list minp))<br />         )<br />       )<br />      x<br />    )<br />        ))<br />        (setq minp (mapcar '- (apply 'mapcar (cons 'min pt)) '(3. 3.)))<br />        (setq maxp (mapcar '+ (apply 'mapcar (cons 'max pt)) '(3. 3.)))<br />        (entmake  (list '(0 . "LWPOLYLINE")<br />           '(100 . "AcDbEntity")<br />           '(100 . "AcDbPolyline")<br />           '(90 . 4)<br />           '(70 . 1)<br />           '(62 . 1)<br />           (cons 10 minp)<br />           (cons 10 (list (car minp) (cadr maxp)))<br />           (cons 10 maxp)<br />           (cons 10 (list (car maxp) (cadr minp)))<br />     )<br />        )<br />      )<br />     lst<br />   );按照分堆成果画出红色矩形框 矩形框偏移3个单位<br />   (princ)<br /> )

世井

我增加的一个可以自行输入外扩距离
(defun c:tt (/ wkjl ss lst obj maxp minp flst nlst maxpx maxpy pt )
  (IF (NULL *wkjl) (setq *wkjl 30.0))
   (setq wkjl (GETREAL (strcat "\n外扩距离<" (rtos *wkjl 2 2) ">:")))
   (if (NULL wkjl) (setq wkjl *wkjl) (setq *wkjl wkjl))
  
  (setq ss (ssget))
  (setq  lst
   (mapcar '(lambda (x)
        (setq obj (vlax-ename->vla-object x))
        (vla-getboundingbox obj 'minp 'maxp)
        (setq
          maxp (mapcar '* '(1.0 1.0) (vlax-safearray->list maxp))
        )
        (setq
          minp (mapcar '* '(1.0 1.0) (vlax-safearray->list minp))
        )
        (list x (car minp) (car maxp) (cadr minp) (cadr maxp))
      )
     (vl-remove-if-not
       '(lambda (x) (= 'ENAME (type x)))
       (apply 'append (ssnamex ss))
     )
   )
  )
  (setq  flst (lambda (lst key)
         (if lst
     (if key
       (progn
         (setq nlst   (list (list (caar lst)
               (cadddr (car lst))
               (last (car lst))
         ))
         maxpx (caddar lst)
         lst   (cdr lst)
         )
         (while (and lst (<= (cadar lst) maxpx))
           (setq nlst  (cons (list (caar lst)
                 (cadddr (car lst))
                 (last (car lst))
           )
           nlst
           )
           maxpx (max maxpx (caddar lst))
           lst   (cdr lst)
           )
         )
         (cons nlst (flst lst key))
       )
       (progn
         (setq nlst   (list (caar lst))
         maxpy (caddar lst)
         lst   (cdr lst)
         )
         (while (and lst (<= (cadar lst) maxpy))
           (setq nlst  (cons (caar lst) nlst)
           maxpy (max maxpy (caddar lst))
           lst   (cdr lst)
           )
         )
         (cons nlst (flst lst key))
       )
     )
         )
       )
  )
  (setq
    lst
     (apply
       'append
       (mapcar
   '(lambda (wlst)
      (flst (vl-sort wlst '(lambda (a b) (< (cadr a) (cadr b))))
      nil
      )
    )
   (flst (vl-sort lst '(lambda (a b) (< (cadr a) (cadr b)))) t)
       )
     )
  )
  (mapcar
    '(lambda (x)
       (setq pt (apply
   'append
   (mapcar
     '(lambda (ent)
        (vla-getboundingbox (vlax-ename->vla-object ent) 'minp 'maxp)
        (list (mapcar '* '(1.0 1.0) (vlax-safearray->list maxp))
          (mapcar '* '(1.0 1.0) (vlax-safearray->list minp))
        )
      )
     x
   )
       ))
       (setq minp (mapcar '- (apply 'mapcar (cons 'min pt)) (list wkjl wkjl)))
       (setq maxp (mapcar '+ (apply 'mapcar (cons 'max pt)) (list wkjl wkjl)))
       (entmake  (list '(0 . "LWPOLYLINE")
          '(100 . "AcDbEntity")
          '(100 . "AcDbPolyline")
          '(90 . 4)
          '(70 . 1)
          '(62 . 1)
          (cons 10 minp)
          (cons 10 (list (car minp) (cadr maxp)))
          (cons 10 maxp)
          (cons 10 (list (car maxp) (cadr minp)))
    )
       )
     )
    lst
  )
  (princ)
)

guosheyang

我先前也写过个类似代码  估计框内图元多了的话 会运行慢   在这儿  http://bbs.mjtd.com/thread-184261-1-1.html   http://bbs.mjtd.com/forum.php?mod=attachment&aid=MTE2ODg2fDVmY2FkNzNjNzdlNDNmZjkxOGZjNmRmZmIxZWQ5OWM1fDE3MzI1MjA2MTc%3D&request=yes&_f=.gif

htlaser

1. (defun c:tet ()
   
2. (defun juxingguolv (ss / ent i j lst1 lst2 maxpoint minpoint nam name1 name2 pmax pmin pt1x pt1y pt2x pt2y pt3x pt3y pt4x pt4y ) ; 过滤掉矩形选择集内的矩形子函数 nam
   
3.     (setq lst1 '())
   
4.     (repeat (setq i (sslength ss))
   
5.       (setq nam (ssname ss (setq i (1- i))))
   
6.       (vla-getboundingbox (vlax-ename->vla-object nam) 'minpoint 'maxpoint)
   
7.       (setq pmax (vlax-safearray->list maxpoint)  pmin (vlax-safearray->list minpoint))
   
8.       (setq lst1 (cons (list pmin pmax nam) lst1))
   
9.     )
   
10.     (setq lst2 lst1)
    
11.     (repeat (setq i (length lst1))
    
12.       (setq nam (nth (setq i (1- i)) lst1))
    
13.       (setq pt1x (car (car nam))  pt1y (cadr (car nam))  pt2x (car (cadr nam))
    
14.             pt2y (cadr (cadr nam))  name1 (caddr nam) )
    
15.       (repeat (setq j (length lst2))
    
16.         (setq ent (nth (setq j (1- j))  lst2 ))
    
17.         (setq pt3x (car (car ent))  pt3y (cadr (car ent)) pt4x (car (cadr ent))
    
18.               pt4y (cadr (cadr ent))   name2 (caddr ent))
    
19.         (if (and (> pt3x pt1x) (> pt3y pt1y)  (< pt4x pt2x) (< pt4y pt2y))
    
20.           (if (ssmemb name2 ss)  (setq ss (ssdel name2 ss))))
    
21.         (if (and (< pt3x pt1x) (< pt3y pt1y) (> pt4x pt2x)(> pt4y pt2y))
    
22.           (if (ssmemb name1 ss) (setq ss (ssdel name1 ss))))))
    
23.     ss
    
24.   )
    
25. 
    
26. (setvar "cmdecho" 0) ;指令执行过程不响应
    
27. (setq ss (ssget (list'(0 . "LWPOLYLINE,CIRCLE"))))
    
28.         (progn
    
29. (setq ss (juxingguolv ss))
    
30.                 (sssetfirst nil ss)
    
31.         (command "_.chprop" SS "" "c" "1" "")
    
32.                
    
33.                 ))

(defun c:tet ()<br /> (defun juxingguolv (ss / ent i j lst1 lst2 maxpoint minpoint nam name1 name2 pmax pmin pt1x pt1y pt2x pt2y pt3x pt3y pt4x pt4y ) ; 过滤掉矩形选择集内的矩形子函数 nam<br />     (setq lst1 '())<br />     (repeat (setq i (sslength ss))<br />       (setq nam (ssname ss (setq i (1- i))))<br />       (vla-getboundingbox (vlax-ename->vla-object nam) 'minpoint 'maxpoint)<br />       (setq pmax (vlax-safearray->list maxpoint)  pmin (vlax-safearray->list minpoint))<br />       (setq lst1 (cons (list pmin pmax nam) lst1))<br />     )<br />     (setq lst2 lst1)<br />     (repeat (setq i (length lst1))<br />       (setq nam (nth (setq i (1- i)) lst1))<br />       (setq pt1x (car (car nam))  pt1y (cadr (car nam))  pt2x (car (cadr nam))<br />             pt2y (cadr (cadr nam))  name1 (caddr nam) )<br />       (repeat (setq j (length lst2))<br />         (setq ent (nth (setq j (1- j))  lst2 ))<br />         (setq pt3x (car (car ent))  pt3y (cadr (car ent)) pt4x (car (cadr ent))<br />               pt4y (cadr (cadr ent))   name2 (caddr ent))<br />         (if (and (> pt3x pt1x) (> pt3y pt1y)  (< pt4x pt2x) (< pt4y pt2y))<br />           (if (ssmemb name2 ss)  (setq ss (ssdel name2 ss))))<br />         (if (and (< pt3x pt1x) (< pt3y pt1y) (> pt4x pt2x)(> pt4y pt2y))<br />           (if (ssmemb name1 ss) (setq ss (ssdel name1 ss))))))<br />     ss<br />   )<br /> <br /> (setvar "cmdecho" 0) ;指令执行过程不响应<br /> (setq ss (ssget (list'(0 . "LWPOLYLINE,CIRCLE"))))<br />         (progn<br /> (setq ss (juxingguolv ss))<br />                 (sssetfirst nil ss)<br />         (command "_.chprop" SS "" "c" "1" "") <br />                 <br />                 ))

guosheyang

http://bbs.mjtd.com/forum.php?mod=attachment&aid=MTE2ODg1fDY4NDY3ODc3NjIyY2Q5NjgyZDJlM2EwODAyYWJhZTcyfDE3MzI1MjA2MTc%3D&request=yes&_f=.gif    这种情况下会出错  麻烦看看

kkq0305

guosheyang 发表于 2021-11-30 00:02
http://bbs.mjtd.com/forum.php?mod=attachment&aid=MTE2ODg1fDY4NDY3ODc3NjIyY2Q5NjgyZDJlM2EwODAyYWJhZTcyfDE3MzI1MjA2MTc%3D&request=yes&_f=.gif    这种情况下会出错  麻烦看看

这个 是相对齐整  你这个  应该 二次分堆 就分出来 了

kkq0305

guosheyang 发表于 2021-11-30 00:07
我先前也写过个类似代码  估计框内图元多了的话 会运行慢   在这儿  http://bbs.mjtd.com/thread-184261-1- ...

不适合 xy方向投影上有有交叉的  没有间隔的  分堆

guosheyang

kkq0305 发表于 2021-11-30 10:44
不适合 xy方向投影上有有交叉的  没有间隔的  分堆

好的   谢谢！

hehoubin

可以返回;((选择集((点表)(点表)(点表)(点表))) (选择集((点表)(点表)(点表)(点表))))这样吗

sunny_8848

请教大家，上面的代码是哪一行修改矩形框的图层的？