I have been messing about with this routine. It's a little different than most Text Align Routines in that
it does not change the justification of the text object & it works with mixed text & mtext.
I thought I would post this "Work In Progress" to see if anyone wants to add there code and / or
comments to the routine. As you can see I'm just getting started but have run out of gas.
So if you're interested jump right in. Comments welcome.
<UPDATED TO Version 1.1>
;; CAB 11.12.08 Version 1.1
;;
;; Align a group of text or mtext objects along there X or Y axis
;; User picks Master text & then text to align under it
;; Does not change the text alignment or justification or combine text
;; Uses the justification of the Master text to set alignment
;; This routine simply moves & rotates the text
;; Will allow Master text on any angle
;;
;; ----- N O T E S ------
;; only supports vertical alignment at this time, will add Horizontal
;; you must select text in order top to bottom, need to allow sorting
;; on the x or y axis, see note on line 47
;; No support for UCS at this time
;;
(defun c:at() (c:TextAlign)) ; shortcut
(defun c:TextAlign (/ t1 xy ent elist ss lst cor dir bang gap npt ename clst i obj
atpm atp$ ppt
atp_decode_mText atp_decode_Text
)
(vl-load-com)
(defun atp_decode_mText (code)
(cond
((vl-position code '(1 4 7)) "Left")
((vl-position code '(2 5 8)) "Center")
((vl-position code '(3 6 9)) "Right")
)
)
(defun atp_decode_Text (code)
;; 3 - acAlignmentAligned
;; 5 - acAlignmentFit
(cond
((vl-position code '(0 6 9 12)) "Left")
((vl-position code '(1 4 7 10 13 3 5)) "Center")
((vl-position code '(2 8 11 14)) "Right")
)
)
;;============================
;; S T A R T H E R E
;;============================
(setvar "errno" 0)
(setq xy "X")
(while
(progn
(initget "V H")
(setq
t1 (entsel
"\nSelect master text to align Verticaly or <\"H\"> to align Horrizontally: "
))
(cond
((null t1) (setq xy "X"))
((= t1 "H") (setq xy "Y"))
((listp t1)
(setq ent (car t1)
elist (entget ent))
(if (not (member (cdr (assoc 0 elist)) '("TEXT" "MTEXT")))
(princ "\nError - must be a text object.")
)
)
(t (princ "\nMissed, Try again."))
)
)
) ; end while
;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;; Note that ssget will order the selections within the selection set only
;; when the picks are one at at time. Therefore any sorting based on X,Y
;; coordinates might want to give priority to those items selected first
;; If the (caar value is 1 then it is a PICK else window or other sel method
;;
;; At this time only the selection set order is being used: version 1.0
(prompt "\nSelect Text to align with Master Text.")
(if (setq ss (ssget '((0 . "TEXT,MTEXT"))))
(progn
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-StartUndoMark (vla-get-activedocument (vlax-get-acad-object)))
(setq lst (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss))))
(setq lst (vl-remove ent lst)) ; remove master if it was selected again
;; got a master text object
(cond
((= (cdr (assoc 0 elist)) "TEXT")
(setq cor (get_box_dtext ent)) ; get the corners '(ll lr ur ul)
(setq atpm (atp_decode_Text (vla-get-Alignment (vlax-ename->vla-object ent))))
)
(t ; mText
(setq cor (get_box_mtext ent)) ; get the corners '(ll lr ur ul)
(setq atpm (atp_decode_mText (vla-get-AttachmentPoint (vlax-ename->vla-object ent))))
)
)
(setq dir (angle (last cor) (car cor)) ; offset direction
bang (angle (car cor)(cadr cor)) ; Base angle
gap (* (cdr(assoc 40 elist)) 0.6666) ; text height of master text
)
;; correct for near zero angle
(if (equal dir (* 2 pi) 0.0001) (setq dir 0.0))
(if (equal bang (* 2 pi) 0.0001) (setq bang 0.0))
(cond ; get next point
((= atpm "Left") (setq npt (polar (car cor) dir gap)))
((= atpm "Center") (setq npt (polar (polar (car cor) bang
(/ (distance (car cor)(cadr cor)) 2.)) dir gap)))
((= atpm "Right") (setq npt (polar (cadr cor) dir gap)))
)
(setq i -1)
(while (setq ename (ssname ss (setq i (1+ i))))
(setq obj (vlax-ename->vla-object ename))
(cond
((= (cdr (assoc 0 (entget ename))) "TEXT")
(setq clst (get_box_dtext ename)) ; get the corners '(ll lr ur ul)
;(setq atp$ (atp_decode_Text (vla-get-Alignment obj)))
)
(t ; mText
(setq clst (get_box_mtext ename)) ; get the corners '(ll lr ur ul)
;(setq atp$ (atp_decode_mText (vla-get-AttachmentPoint obj)))
)
)
(cond ; get base point for MOVE [TL TC TR]
((= atpm "Left") (setq ppt (vlax-3d-point(last clst))))
((= atpm "Center")
(setq ppt (vlax-3d-point(polar (last clst) bang (/ (distance (car clst)(cadr clst)) 2.)))))
((= atpm "Right") (setq ppt (vlax-3d-point(caddr clst))))
)
;(command "rectang" "non" (car clst) "non" (caddr clst)) ; debug
;; Move the text into place & rotate if needed
(vla-move obj ppt (vlax-3d-point npt)) ; WCS
(if (not(equal bang (vla-get-rotation obj) 0.0001))
(vla-rotate obj (vlax-3d-point npt) (- bang (vla-get-rotation obj)))
)
;; advance the point for top left of next text ent
(setq npt (polar npt dir (+ gap (distance (car clst)(last clst)))))
;(setq clst (get_box_dtext ename)) ; debug
;(command "rectang" "non" (car clst) "non" (caddr clst)) ; debug
)
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
) ; progn
) ; endif
;;++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
(princ)
)
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; + get_box_mtext +
;;; + Created by C. Alan Butler +
;;; + Copyright 2005 +
;;; + by Precision Drafting & Design All Rights Reserved. +
;;; + Contact at ab2draft@TampaBay.rr.com +
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
;;; VERSION
;;; 1.2 Jan 24, 2006 UCS corrections
;;;
;;; FUNCTION
;;; Return Box coordinates for an Mtext object in any UCS, any angle.
;;;
;;; USAGE
;;; (box_mtext ent)
;;;
;;; ARGUMENTS
;;; ent = mtext ename
;;;
;;; RETURNS
;;; list of 4 points for box, (ll lr ur ul)
;;;
;;; PLATFORMS
;;; 2000+ Tested in 2000 only
(defun get_box_mtext (ent / elst p10 txth ang vec wid hgt dxf UCSangle
attpt ul ur lr ll)
(defun dxf (code elst)
(cdr (assoc code elst))
)
;; incase it is a list, (ename point)
(and (listp ent) (setq ent (car ent)))
(setq elst (entget ent))
(setq p10 (trans (dxf 10 elst) 0 1) ; insertion point WCS to UCS
txth (dxf 40 elst) ; text height
wid (dxf 42 elst) ; full width
hgt (dxf 43 elst) ; full height
ang (dxf 50 elst) ; rotation angle in UCS
attpt (dxf 71 elst) ; attachment point code
)
;|--------------------------------------------------------------
;; CAB 01/24/2006 removed as the ang fron DXF code 50 os in UCS
;; correct for UCS
(setq ang (- ang (angle (trans '(0.0 0.0 0.0) 1 0)
(trans '(1.0 0.0 0.0) 1 0)))
)
;; angles 90 = (/ pi 2) 180 = pi 270 = (* pi 1.5)
---------------------------------------------------------------|;
;; Get upper left (ul) from insert point (p10)
(cond ((= attpt 1) (setq ul p10)) ; top left
((= attpt 2) (setq ul (polar p10 (+ pi ang) (/ wid 2)))) ; top center
((= attpt 3) (setq ul(polar p10 (+ pi ang) wid))) ; top right
((= attpt 4) (setq ul (polar p10 (+ (/ pi 2) ang) (/ hgt 2)))) ; middle left
((= attpt 5) ; middle center
(setq ul (polar (polar p10 (+ pi ang) (/ wid 2)) (+ (/ pi 2) ang) (+ (/ hgt 2)))))
((= attpt 6) ; middle right
(setq ul (polar (polar p10 (+ pi ang) wid) (+ (/ pi 2) ang) (+ (/ hgt 2)))))
((= attpt 7) (setq ul (polar p10 (+(/ pi 2) ang) hgt))) ; bottom left
((= attpt 8) ; bottom center
(setq ul (polar (polar p10 (+ pi ang) (/ wid 2)) (+ (/ pi 2) ang) hgt)))
((= attpt 9) ; bottom right
(setq ul (polar (polar p10 (+ pi ang) wid) (+ (/ pi 2) ang) hgt)))
);cond
(setq ur (polar ul ang wid)
lr (polar ur (+ ang (* pi 1.5)) hgt)
ll (polar lr (+ ang pi) wid)
);setq
(list ll lr ur ul)
);boxmtext
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;; + box_text +
;;; + Created by C. Alan Butler +
;;; + Copyright 2005 +
;;; + by Precision Drafting & Design All Rights Reserved. +
;;; + Contact at ab2draft@TampaBay.rr.com +
;;; ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
;;;
;;; VERSION
;;; 1.2 Jan 24, 2006 UCS corrections
;;;
;;; FUNCTION
;;; Return Box coordinates for an dtext object in any UCS, any angle.
;;;
;;; USAGE
;;; (box_text ent)
;;;
;;; ARGUMENTS
;;; ent = text ename
;;;
;;; RETURNS
;;; list of 4 points for box, (ll lr ur ul)
;;;
;;; PLATFORMS
;;; 2000+ Tested in 2000 only
;;; FUNCTION
(defun get_box_dtext (ent / i ename elist lst lst2 tb tb1 tb2 tlen thi ll lr
ur ul ang angg UCSang llx lrx urx ulx lly lry ury uly all
avg err cntlst
)
(setq UCSang (angle (trans '(0.0 0.0 0.0) 1 0)
(trans '(1.0 0.0 0.0) 1 0)
)
)
;;+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
;; get the bounding box
;;+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
(setq elist (entget ent)
ang (cdr (assoc 50 elist)) ; text angle
tb (textbox elist) ; Note thst I had some problems with this
;tb (textbox (list (assoc 1 elist) (assoc 40 elist)(assoc 7 elist)));(textbox (list (assoc 1 elist))) ; CAB 11.11.08
tb1 (car tb) ; Lower Left Relative to text
tb2 (cadr tb) ; Upper Right relative to text
tlen (- (car tb2) (car tb1))
thi (- (cadr tb2) (cadr tb1))
;; new ll CAB 01/24/06
ll (MapCar '+ (trans (cdr (assoc 10 elist)) 0 1) tb1)
ang (- ang UCSang) ; correct for UCS
lr (polar ll ang tlen)
ur (polar ll (+ ang (angle tb1 tb2)) (distance tb1 tb2))
ul (polar ll (+ ang (/ pi 2)) thi)
) ;setq
;;+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
(list ll lr ur ul)
) ; end defun box_dtext
;;; x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x-x