Aligning blocks

Does anyone has a routine that will lign up either horizontally or
vertically all selected blocks with attributes  in the specified base
point?  Thanks.
 
 

 

I striped this from my dialog based routine:
I use it to align blocks.

Gary

;"Top"
;(al_move 3))

;"Bottom"
;(al_move 4))

;"Left"
;(al_move 5))

;"Right"
;(al_move 6))


(defun al_move (carnum / sslist ss num car-func i fixtype flevel ename etype
enxy dist base-pt to-pt)
(setvar "osmode" 0)
(setq sslist (al_select))
(setq ename (car sslist)
ss (cadr sslist)
num (sslength ss)
i (- 1)
)
(setq car-func
(cond
((= carnum 3) car)
((= carnum 4) cadr)
((= carnum 5) caddr)
((= carnum 6) cadddr)
); cond
); setq
(setq fixtype (al_dxf 0 ename))
(setq flevel (car-func (al_xy fixtype ename)))
(repeat num
(setq ename (ssname ss (setq i (1+ i))))
(setq etype (al_dxf 0 ename))
(setq enxy (car-func (al_xy etype ename)))
(setq dist (- flevel enxy)
base-pt '(0 0 0)
)
(setq to-pt
(cond
((or (= carnum 3) (= carnum 4))
(list 0 dist 0)
)
((or (= carnum 5) (= carnum 6))
(list dist 0 0)
)
); cond
); setq
(command "MOVE" ename "" base-pt to-pt)
); repeat
(princ)
); al_move

(defun al_select (/ ss enfixed)
(setq enfixed nil ss nil)
(prompt "\nSelect the fixed entity ")
(while (not enfixed)
(setq enfixed (car (entsel)))
(if (not enfixed)
(prompt "\nSelect an entity ")
)
); while
(prompt "\nSelect the entities to be aligned ")
(while (not ss)
(setq ss (ssget))
(if (not ss)
(prompt "\nNo entities were selected ")
)
); while
(list enfixed ss)
); al_select

(defun al_xy (etype ename)
(setq xylist
(cond
((= etype "LINE") (al_do_line ename))
((= etype "CIRCLE") (al_do_circle ename))
((= etype "ARC") (al_do_arc ename))
((= etype "POLYLINE") (al_do_pline ename))
((= etype "INSERT") (al_do_insert ename))
((= etype "TEXT") (al_do_text ename))
); cond
); setq
); al_xy

(defun al_dxf (code ename)
(cdr (assoc code (entget ename)))
); al_dxf

(defun al_do_line (ename / p1 p2 x1 x2 y1 y2
topy bottmy leftx rightx)
(setq p1 (al_dxf 10 ename)
p2 (al_dxf 11 ename)
x1 (car p1)
y1 (cadr p1)
x2 (car p2)
y2 (cadr p2)
)
(if (> y1 y2)
(setq topy y1 bottmy y2)
(setq topy y2 bottmy y1)
); if
(if (> x1 x2)
(setq rightx x1 leftx x2)
(setq rightx x2 leftx x1)
); if
(list topy bottmy leftx rightx)
); al_do_line

(defun al_do_circle (ename / cen rad cenx ceny
topy bottmy leftx rightx)
(setq cen (al_dxf 10 ename)
rad (al_dxf 40 ename)
cenx (car cen)
ceny (cadr cen)
topy (+ ceny rad)
bottmy (- ceny rad)
leftx (- cenx rad)
rightx (+ cenx rad)
)
(list topy bottmy leftx rightx)
); al_do_circle

(defun al_do_arc (ename / rad ang1 ang2 cenx ceny
p1 p2 p1x p1y p2x p2y topy bottmy leftx rightx)
(setq cen (al_dxf 10 ename)
rad (al_dxf 40 ename)
ang1 (al_dxf 50 ename)
ang2 (al_dxf 51 ename)
cenx (car cen)
ceny (cadr cen)
p1 (polar cen ang1 rad)
p2 (polar cen ang2 rad)
p1x (car p1)
p2x (car p2)
p1y (cadr p1)
p2y (cadr p2)
)
;; test for topy
(if (or
(and (< ang1 (/ pi 2.0)) (> ang1 ang2))
(and (> ang2 (/ pi 2.0))
(or (< ang1 (/ pi 2.0)) (> ang1 ang2))
)
); or
(setq topy (+ ceny rad))
(setq topy (max p1y p2y))
); if topy
;; test for bottmy
(if (or
(and (< ang1 (* pi 1.5)) (> ang1 ang2))
(and (> ang2 (* pi 1.5))
(or (< ang1 (* pi 1.5)) (> ang1 ang2))
)
); or
(setq bottmy (- ceny rad))
(setq bottmy (min p1y p2y))
); if bottmy
;; test for leftx
(if (or
(and (< ang1 pi) (> ang1 ang2))
(and (> ang2 pi)
(or (< ang1 pi) (> ang1 ang2))
)
); or
(setq leftx (- cenx rad))
(setq leftx (min p1x p2x))
); if leftx
;; test for rightx
(if (and (> ang2 0.0) (> ang1 ang2))
(setq rightx (+ cenx rad))
(setq rightx (max p1x p2x))
); if rightx
(list topy bottmy leftx rightx)
); al_do_arc

(defun al_do_pline (ename / dename xylist)
(command "copy" ename "" "0,0,0" "0,0,0")
(setq dename (entlast))
(command "LAYER" "M" "al-complex" "")
(command "CHPROP" dename "" "LA" "al-complex" "")
(setq xylist (al_do_complex dename))
); al_do_pline

(defun al_do_complex (ename / sscmplx numcmplx n
cmplx-list toplist bottmlist leftlist rightlist
enamecmplx etypecmplx cmplx-list item)
(command "explode" ename)
(setq sscmplx (ssget "X" '((8 . "AL-COMPLEX"))))
(setq numcmplx (sslength sscmplx)
n (- 1)
cmplx-list nil
toplist nil
bottmlist nil
leftlist nil
rightlist nil
)
(repeat numcmplx
(setq enamecmplx (ssname sscmplx
(setq n (1+ n)))
)
(setq etypecmplx (al_dxf 0 enamecmplx))
(setq enxycmplx (al_xy etypecmplx enamecmplx))
(setq cmplx-list (append cmplx-list
(list enxycmplx))
)
); repeat
(foreach item cmplx-list
(setq toplist (do-plist car item toplist))
(setq bottmlist
(do-plist cadr item bottmlist)
)
(setq leftlist (do-plist caddr item leftlist))
(setq rightlist
(do-plist cadddr item rightlist)
)
); foreach
(setq topy (eval (append '(max) toplist))
bottmy (eval (append '(min) bottmlist))
leftx (eval (append '(min) leftlist))
rightx (eval (append '(max) rightlist))
)
(command "erase" sscmplx "")
(list topy bottmy leftx rightx)
); al_do_complex

(defun do-plist (ccar item tblrlist)
(setq tblr (ccar item))
(setq tblrlist (append tblrlist (list tblr)))
); do-plist

(defun al_do_insert (ename / bname ins-pt
tblist en base-pt newlyr elist oldlyr
newlist num cename xylist ssablk)
(setq bname (al_dxf 2 ename)
ins-pt (al_dxf 10 ename)
tblist (tblsearch "BLOCK" bname)
en (cdr (assoc -2 tblist))
base-pt (cdr (assoc 10 tblist))
newlyr (cons 8 "AL-COMPLEX")
)
(entmake (list '(0 . "BLOCK") '(2 . "*U")
'(70 . 1)(cons 10 base-pt)
(cons 8 "AL-COMPLEX")
); list
); entmake
(while en
(setq elist (entget en)
oldlyr (assoc 8 elist)
newlist (subst newlyr oldlyr elist)
)
(entmake newlist)
(setq en (entnext en))
); while
(setq num (entmake '((0 . "ENDBLK")) ))
(entmake (list '(0 . "INSERT") (cons 2 num)
(cons 10 ins-pt))
)
(setq cename (entlast))
(setq xylst (al_do_complex cename))
(setq ssablk (ssget "X" '((2 . "`*U*"))))
(command "erase" ssablk "")
xylst
); al_do_insert

(defun al_do_text (ename / xylist ll ur en tlist)
(command "ucs" "Entity" ename)
(setq xylst (textbox (entget ename)))
(setq ll (car xylst)
ur (cadr xylst)
)
(command "LINE" ll ur "")
(command "ucs" "p")
(setq en (entlast))
(setq tlist (al_do_line en))
(entdel en)
tlist
); al_do_text