Align Blocks automatically - lisp

[Yamishon_Noah]

Hi

I searched lot for this activity but could not find. please do the needful

I have several blocks placed in drawing but problem is these blocks overlapping slightly to another block. 

I want to have lisp that will align these blocks properly. (I have to avoid overlapping).

like if I select multiple blocks then all these overlapped blocks will slightly move (any direction) to avoid overlap and re positioned.

Kindly see attached dwg, I have shown current condition and how I want output.

I have more than 100 dwgs and each have more than 150blocks like this. by manually it takes plenty of time.

[m_badran]

Hi, I think re scale the blocks is best solution for you.

[Yamishon_Noah]

Hi,

No, re-scaling shall not be done. as the block size fixed for the dwg.

One block has to see its boundary and if any other blocks overlapping then it has to move till overlapped (distant - any direction) automatically, this process shall has to execute for selected blocks or all blocks in a dwg.

I hope you will understand my query.

Thanks

MK

[marko_ribar]

This is my version... It is applicable only for single overlapping group and disposition is randomly processed according to disposition matrix... So your actually upper 2 blocks in my version are scattered to the right... If that's not such a problem - final disposition is scattered near center point of group so the task is solved in most situations correctly, but without checking dispositions of similar attributed blocks...

(defun c:scatterblks ( / dispositionmatrix s i m l b c k rn mn w l bp rh )

  (vl-load-com)

  (defun dispositionmatrix ( n / f k r l )
    (setq f (1+ (fix (sqrt (- n 0.5)))))
    (setq k 0)
    (repeat f
      (repeat f
        (setq k (1+ k))
        (if (<= k n)
          (setq r (cons 1 r))
          (setq r (cons 0 r))
        )
      )
      (setq l (cons (reverse r) l) r nil)
    )
    (reverse l)
  )

  (prompt "\nSelect overlapping group of blocks...")
  (setq s (ssget "_:L" '((0 . "INSERT"))))
  (if s
    (progn
      (setq i (sslength s))
      (setq m (dispositionmatrix i))
      (repeat i
        (setq l (cons (list (acet-ent-geomextents (setq b (ssname s (setq i (1- i))))) b) l))
      )
      (setq c (mapcar (function (lambda ( x ) (/ x (length l)))) (apply (function mapcar) (cons (function +) (mapcar (function (lambda ( x y ) (mapcar (function (lambda ( a b ) (/ (+ a b) 2))) x y))) (mapcar (function caar) l) (mapcar (function cadar) l))))))
      (setq k 0)
      (foreach r m
        (foreach v r
          (if (= v 1)
            (setq rn (cons (nth k l) rn) k (1+ k))
            (setq rn (cons nil rn))
          )
        )
        (setq mn (cons (reverse rn) mn) rn nil)
      )
      (setq mn (reverse mn))
      (setq w (apply (function max) (mapcar (function (lambda ( x ) (apply (function +) (mapcar (function (lambda ( y ) (abs (- (car (cadr (car y))) (car (car (car y))))))) (vl-remove (function null) x))))) mn)))
      (setq l (apply (function max) (mapcar (function (lambda ( x ) (apply (function +) (mapcar (function (lambda ( y ) (abs (- (cadr (cadr (car y))) (cadr (car (car y))))))) (vl-remove (function null) x))))) (apply (function mapcar) (cons (function list) mn)))))
      (setq bp (mapcar (function +) c (list (- (/ w 2)) (- (/ l 2)))))
      (setq rh 0.0)
      (foreach rn mn
        (setq bp (mapcar (function +) bp (list 0.0 rh)))
        (setq rh 0.0)
        (foreach vn rn
          (if vn
            (progn
              (vla-move (vlax-ename->vla-object (cadr vn)) (vlax-3d-point (caar vn)) (vlax-3d-point bp))
              (setq bp (mapcar (function +) bp (list (abs (- (car (cadr (car vn))) (car (car (car vn))))) 0.0)))
            )
          )
          (if (< rh (abs (- (cadr (cadr (car vn))) (cadr (car (car vn))))))
            (setq rh (abs (- (cadr (cadr (car vn))) (cadr (car (car vn))))))
          )
        )
        (setq bp (subst (- (car c) (/ w 2)) (car bp) bp))
      )
    )
  )
  (princ)
)

[marko_ribar]

There was a mistake in my previously posted code... The problem was that I haven't tested it with number of blocks that isn't square root-able... This should fix this issue...

(defun c:scatterblks ( / dispositionmatrix s i m l b c k rn mn w h bp rh ) (vl-load-com) (defun dispositionmatrix ( n / f k r l ) (setq f (1+ (fix (sqrt (- n 0.5))))) (setq k 0) (repeat f (repeat f (setq k (1+ k)) (if (<= k n) (setq r (cons 1 r)) (setq r (cons 0 r)) ) ) (setq l (cons (reverse r) l) r nil) ) (reverse l) ) (prompt "\nSelect overlapping group of blocks...") (setq s (ssget "_:L" '((0 . "INSERT")))) (if s (progn (setq i (sslength s)) (setq m (dispositionmatrix i)) (repeat i (setq l (cons (list (acet-ent-geomextents (setq b (ssname s (setq i (1- i))))) b) l)) ) (setq c (mapcar (function (lambda ( x ) (/ x (length l)))) (apply (function mapcar) (cons (function +) (mapcar (function (lambda ( x y ) (mapcar (function (lambda ( a b ) (/ (+ a b) 2))) x y))) (mapcar (function caar) l) (mapcar (function cadar) l)))))) (setq k 0) (foreach r m (foreach v r (if (= v 1) (setq rn (cons (nth k l) rn) k (1+ k)) (setq rn (cons nil rn)) ) ) (setq mn (cons (reverse rn) mn) rn nil) ) (setq mn (reverse mn)) (setq w (apply (function max) (mapcar (function (lambda ( x ) (apply (function +) (mapcar (function (lambda ( y ) (if y (abs (- (car (cadr (car y))) (car (car (car y))))) 0.0))) x)))) mn))) (setq h (apply (function max) (mapcar (function (lambda ( x ) (apply (function +) (mapcar (function (lambda ( y ) (if y (abs (- (cadr (cadr (car y))) (cadr (car (car y))))) 0.0))) x)))) (apply (function mapcar) (cons (function list) mn))))) (setq bp (mapcar (function -) c (list (/ w 2) (/ h 2)))) (setq rh 0.0) (foreach rn mn (setq bp (mapcar (function +) bp (list 0.0 rh))) (setq rh 0.0) (foreach vn rn (if vn (progn (vla-move (vlax-ename->vla-object (cadr vn)) (vlax-3d-point (caar vn)) (vlax-3d-point bp)) (setq bp (mapcar (function +) bp (list (abs (- (car (cadr (car vn))) (car (car (car vn))))) 0.0))) ) ) (if (and vn (< rh (abs (- (cadr (cadr (car vn))) (cadr (car (car vn))))))) (setq rh (abs (- (cadr (cadr (car vn))) (cadr (car (car vn)))))) ) ) (setq bp (subst (- (car c) (/ w 2)) (car bp) bp)) ) ) ) (princ) ) 
 

[Anonymous]

Hello Brother, What is command for your lisp program when I loaded in autocad?

[Kent1Cooper]

---

@Anonymous wrote:

.... What is command for your lisp program when I loaded in autocad?

---

Whenever a command is defined with this kind of starting line:
   (defun c:scatterblks ....

the command name is always the part immediately after the c:, in this case, SCATTERBLKS [not case-sensitive].

[Anonymous]

Thanks for this great solution! How would someone update the script to add some predefined space between blocks? (Both vertically and horizontally)

[marko_ribar]

Here you go...

(defun c:scatterblks-with-gaps ( / dispositionmatrix s g i m l b c k rn mn w h bp rh )

  (vl-load-com)

  (defun dispositionmatrix ( n / f k r l )
    (setq f (1+ (fix (sqrt (- n 0.5)))))
    (setq k 0)
    (repeat f
      (repeat f
        (setq k (1+ k))
        (if (<= k n)
          (setq r (cons 1 r))
          (setq r (cons 0 r))
        )
      )
      (setq l (cons (reverse r) l) r nil)
    )
    (reverse l)
  )

  (prompt "\nSelect overlapping group of blocks...")
  (setq s (ssget "_:L" '((0 . "INSERT"))))
  (initget 4)
  (setq g (getdist "\nPick or specify gap distance <0.0> : "))
  (if (null g)
    (setq g 0.0)
  )
  (if s
    (progn
      (setq i (sslength s))
      (setq m (dispositionmatrix i))
      (repeat i
        (setq l (cons (list (acet-ent-geomextents (setq b (ssname s (setq i (1- i))))) b) l))
      )
      (setq c (mapcar (function (lambda ( x ) (/ x (length l)))) (apply (function mapcar) (cons (function +) (mapcar (function (lambda ( x y ) (mapcar (function (lambda ( a b ) (/ (+ a b) 2))) x y))) (mapcar (function caar) l) (mapcar (function cadar) l))))))
      (setq k 0)
      (foreach r m
        (foreach v r
          (if (= v 1)
            (setq rn (cons (nth k l) rn) k (1+ k))
            (setq rn (cons nil rn))
          )
        )
        (setq mn (cons (reverse rn) mn) rn nil)
      )
      (setq mn (reverse mn))
      (setq w (apply (function max) (mapcar (function (lambda ( x ) (apply (function +) (mapcar (function (lambda ( y ) (if y (abs (- (car (cadr (car y))) (car (car (car y))))) 0.0))) x)))) mn)))
      (setq h (apply (function max) (mapcar (function (lambda ( x ) (apply (function +) (mapcar (function (lambda ( y ) (if y (abs (- (cadr (cadr (car y))) (cadr (car (car y))))) 0.0))) x)))) (apply (function mapcar) (cons (function list) mn)))))
      (setq bp (mapcar (function -) c (list (+ (/ w 2) (/ (* (1- (length (car m))) g) 2)) (+ (/ h 2) (/ (* (1- (length m)) g) 2)))))
      (setq rh 0.0)
      (foreach rn mn
        (setq bp (mapcar (function +) bp (list 0.0 rh)))
        (setq rh 0.0)
        (foreach vn rn
          (if vn
            (progn
              (vla-move (vlax-ename->vla-object (cadr vn)) (vlax-3d-point (caar vn)) (vlax-3d-point bp))
              (setq bp (mapcar (function +) bp (list (+ g (abs (- (car (cadr (car vn))) (car (car (car vn)))))) 0.0)))
            )
          )
          (if (and vn (< rh (+ g (abs (- (cadr (cadr (car vn))) (cadr (car (car vn))))))))
            (setq rh (+ g (abs (- (cadr (cadr (car vn))) (cadr (car (car vn)))))))
          )
        )
        (setq bp (subst (- (car c) (+ (/ w 2) (/ (* (1- (length (car m))) g) 2))) (car bp) bp))
      )
    )
  )
  (princ)
)

HTH. M.R.

[Anonymous]

Amazing! Thank you so much for the prompt reply!

It works like a charm! 

[pukkalapoom]