;; Juan Villarreal 11.26.

2010
;-------------------------------------------------------------------------------------------------------------------------------;-------------------------------------- GATHERING TABLE INFORMATION ----------------------------------;-------------------------------------------------------------------------------------------------------------------------------(defun tableinfo ( ss / n entlist)
(setq n 0)
(repeat (sslength ss)
(setq entlist (entget (ssname ss n)))
(cond ((member (cdr (assoc 0 entlist)) '("LINE" "POLYLINE"))
(getlinepts entlist)(setq linelist (cons (ssname ss n) linelist)))
((member (cdr (assoc 0 entlist)) '("TEXT" "MTEXT"))
(setq textlist (cons (ssname ss n) textlist)))
((member (cdr (assoc 0 entlist)) '("INSERT"))
(setq blocklist (cons (ssname ss n) blocklist)))
)
(setq n (1+ n))
)
)
;-------------------------- Cell Count/Height/Width Determination --------------------;;Gathers x and y positions of lines and polylines in separate lists
;;This is used to determine height/width & # of rows/columns
;;Line info must be gathered first in order to determine
;;cell position of any other gathered information
;-------------------------------------------------------------------------------------(defun getlinepts (alist / x xpt ypt)
(foreach x alist
(if (member (car x) '(10 11))
(progn
(if (not (vl-position (setq xpt (atof (rtos (car (trans (cdr x) 0 1))
2 8))) lpxlist))
(setq lpxlist (cons xpt lpxlist)))
(if (not (vl-position (setq ypt (atof (rtos (cadr (trans (cdr x) 0 1)
) 2 8))) lpylist))
(setq lpylist (cons ypt lpylist)))
)
)
)
);defun
;---------------------------- Text Info and Cell Position ---------------------------------------------------;;Determine cell position by insertionpoint of text objects
;;(Using text center is probably more reliable)
;;Create list of lists containing row, column, textstring and textheight
;;to be used to fill acad table after creation
;;If row and column is already in list, replace with combined string
;------------------------------------------------------------------------------------------------------------(defun gettxtinfo (alist / x vlaobj pos rpos cpos expos)
(setq vlaobj (vlax-ename->vla-object txt)
pos (trans (vlax-safearray->list (vlax-variant-value (vla-get-insertionp
oint vlaobj))) 0 1)
rpos (1- (vl-position (cadr pos)(vl-sort (cons (cadr pos) lpylist) '>)))
cpos (if (zerop rpos) 0 (1- (vl-position (car pos) (vl-sort (cons (car p
os) lpxlist) '<)))))
(if (setq expos (vl-position (list rpos cpos) (mapcar '(lambda (x)(list (car (ca

r x)) (cadr (car x)))) tinfo)))

(setq tinfo
(replace tinfo expos (list (car (nth expos tinfo))
(if (> (cadr pos) (caddr (car (nth expos tinfo))))
(strcat (vla-fieldcode vlaobj) " " (cadr (nth expos tinfo)))
(strcat (cadr (nth expos tinfo)) " " (vla-fieldcode vlaobj))
) (caddr (nth expos tinfo)))))
(setq tinfo
(cons
(list
(list rpos cpos (cadr pos))
(vla-fieldcode vlaobj)
(vla-get-height vlaobj)
)
tinfo)))
(vla-delete vlaobj)
);defun
;--------------------------- Block Info and Cell Position -----------------------------------------------------;;Gather block information
;;determine cell position according to insertion point
;;Create list of lists containing row, column, block objectid, attribute id, att
ributetextstring and scale factor
;--------------------------------------------------------------------------------------------------------------(defun getblockinfo (obj / pos rpos cpos bname objid bobj attid)
(if (= (type obj) 'ename)
(setq obj (vlax-ename->vla-object obj))
)
(setq pos (trans (vlax-safearray->list (vlax-variant-value (vla-get-insertionpoi
nt obj))) 0 1)
rpos (1- (vl-position (cadr pos)(vl-sort (cons (cadr pos) lpylist) '>)))
cpos (if (zerop rpos) 0 (1- (vl-position (car pos) (vl-sort (cons (car p
os) lpxlist) '<))))
bname (vla-get-name obj)
bobj (vla-item (vla-get-blocks ActDoc) bname))
(vlax-for i bobj
(if (eq (vla-get-objectname i) "AcDbAttributeDefinition")
(setq attid (append attid (list (vla-get-objectid i))))
)
)
(setq objid (vla-get-objectid bobj))
(setq binfo (cons (list (list rpos cpos) objid
(if (= (vla-get-hasattributes obj) :vlax-true)
(mapcar
'(lambda (x y) (cons y (vla-get-textstring x)))
(vlax-safearray->list (variant-value (vla-getattributes obj)))
attid
)
)
(vla-get-xscalefactor obj)
) binfo))
(vla-delete obj)
)
;----------------------------------------------------------------------------------------------------------------------;-------------------------------------------- REPLACE by Charles Alan Butler-------------------------------------------;;Cab's replace function used in this routine to avoid overwriting cells and to
update cell merge lists

;----------------------------------------------------------------------------------------------------------------------(defun replace (lst i itm)

(setq i (1+ i))
(mapcar
'(lambda (x)
(if (zerop (setq i (1- i))) itm x)
)
lst
)
)
;-------------------------Q&D Number Accumulation--------------------------;Used in this routine for polar distances to determine which cells to merge.
;;Recursive function possible. Ask Gile (recursion master) if desired.
(defun acnumlist (nlist / acnlist)
(repeat (length nlist)
(setq acnlist (cons (apply '+ nlist) acnlist)
nlist (reverse (cdr (reverse nlist))))
)
acnlist
)
;-------------------------------------------------------------------------------------------------------------------;------------------------------------------- CONVERT OLD TABLE ROUTINE ---------------------------------------------;-------------------------------------------------------------------------------------------------------------------(defun c:COT (/ ActDoc *error* orerror otcontents textlist
colwidths
i
mlist
p0
*Space* lpxlist
tinfo
cwidths
check
hmergelist tstyle
spos
tstylelst lpylist
blocklist rowheights selsets
vmergelist
tstylelst2 tstylelst3
kword
linelist
binfo
rheights
ssitem
tblobj mergekword)
(vl-load-com)
(setq oerror *error*)
(defun *error* ( msg )
(princ (strcat "\n<" msg ">\n"))
(mapcar '(lambda (x)(and x (not (vlax-object-released-p x))(vlax-release
-object x))) (list ssitem))
(setq *error* oerror)
(setvar 'nomutt 0)
(vla-EndUndoMark ActDoc)
(princ)
);defun *error*
(setq ActDoc (vla-get-activedocument (vlax-get-acad-object))
*Space* (vlax-get-property ActDoc (nth (vla-get-ActiveSpace ActDoc)'("Pa
perSpace" "ModelSpace")))
tstylelst (acad_strlsort
(vlax-for i
(setq tstyle (vla-item (vla-get-dictionaries ActDoc) "A
CAD_TABLESTYLE"))
(setq tstylelst (cons (vla-get-name i) tstylelst))))
i -1)
(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)

(setq tstylelst2
(mapcar
'(lambda (x / txt)
(setq txt x spos 0)
(while (setq spos (vl-string-position (ascii " ") txt spos))
(setq txt (vl-string-subst "" " " txt spos))
)
txt
)
tstylelst
)
)
(initget (setq tstylelst3 (apply 'strcat (mapcar '(lambda (x)
(if (nth (1+ (setq i (1+ i))) tstylelst2)
(strcat x " ") (strcat x))) tstylelst2))))
(setq spos -3)
(while (setq spos (vl-string-position (ascii " ") tstylelst3 (+ spos 3)))
(setq tstylelst3 (vl-string-subst " / " " " tstylelst3 spos))
)
(setq kword
(if (setq kword (getkword (strcat "\nSelect Table Style: [ " tstylelst3 " ]:<Sta
ndard>"))) kword "Standard"))
(setq kword (nth (vl-position kword tstylelst2) tstylelst))
(initget "Yes No")
(setq mergekword (if (setq mergekword (getkword "\nSearch for merged cells? [ Ye
s / No ]:<Yes>")) mergekword "Yes"))
(vla-put-horzcellmargin (vla-item tstyle kword) 0.0)
(vla-put-vertcellmargin (vla-item tstyle kword) 0.0)
(setq otcontents (ssget))
(princ "\nSorting Line Info...")
(tableinfo otcontents)
(setq lpxlist (vl-sort lpxlist '<) lpylist (vl-sort lpylist '>))
(princ "\nSorting Text Info...")
(mapcar '(lambda (txt)(gettxtinfo (entget txt))) textlist)
(princ "\nSorting Block Info...")
(mapcar '(lambda (blk)(getblockinfo blk)) blocklist)
(setq colwidths (mapcar '(lambda (x)(- (nth (1+ (vl-position x lpxlist)) lpxlist
) x))(reverse (cdr (reverse lpxlist))))
rowheights (mapcar '(lambda (x)(- x (nth (1+ (vl-position x lpylist)) lpyl
ist)))(reverse(cdr (reverse lpylist)))))
(setq p0 (vlax-3d-point (trans (list (car lpxlist) (car lpylist) 0.0) 1 0)));;<--Table Placement (Currently using Top Left corner)
(if (eq mergekword "Yes")
(progn
(princ "\nSearching for merged cells...")
(princ)
(setvar 'nomutt 1)
;-----------------------------------Method to determine which cells to merge------------------------------------------;Method fails if missed selection is not possible at zoom level.
;Currently only merges horizontally or vertically;
;To determine which cells to merge, a selection at point is used.
;For each row, a selection is attempted at each vertical line at row's center.
;If no selection is made, the point is at the center or left of horizontally mer
ged cells.
;For each column, a selection is attempted at each horizontal line at column's c
enter.
;If no selection is made, the point is at the center or upper region of vertical
ly merged cells.

;Continuation of merging is determined by a 'consecutive miss'.

;When a 'consecutive miss' is made, max column/row item is replaced by the next
column/row.
;---------------------------------------------------------------------------------------------------------------------(setq selsets (vla-get-selectionsets ActDoc))
(vl-catch-all-error-p (vl-catch-all-apply 'vla-add (list selsets "InxCheckSet"))
)
(setq ssitem (vla-item selsets "InxCheckSet")
cwidths (acnumlist colwidths)
rheights (acnumlist rowheights));;col widths & row heights accumulated f
or polar use
(mapcar '(lambda (pt rh)
(mapcar '(lambda (x)
(vl-catch-all-error-p (vl-catch-all-apply 'vla-clear (list ssitem)))
(vla-selectatpoint ssitem (vlax-3d-point (polar (list (car lpxlist) (+ pt (/
rh 2)) 0.0) 0 x)))
(if (zerop (vla-get-count ssitem))
(if check
(setq hmergelist (replace hmergelist 0 (replace mlist 3 (1+ (vl-posit
ion x cwidths)))))
(setq hmergelist
(cons
(setq mlist
(list
(1- (vl-position pt lpylist))
(vl-position x cwidths)
(1- (vl-position pt lpylist))
(1+ (vl-position x cwidths))
)) hmergelist)
check T)
);if
(setq check nil mlist nil)
));lambda
cwidths
);mapcar
);lambda
(member (nth 2 lpylist) lpylist)
(cdr rowheights)
);mapcar
(mapcar '(lambda (pt cw)
(mapcar '(lambda (x)
(vl-catch-all-error-p (vl-catch-all-apply 'vla-clear (list ssitem)))
(vla-selectatpoint ssitem (vlax-3d-point (polar (list (+ pt (/ cw 2)) (car l
pylist) 0.0) (* pi 1.5) x)))
(if (zerop (vla-get-count ssitem))
(if check
(setq vmergelist (replace vmergelist 0 (replace mlist 2 (1+ (vl-posit
ion x rheights)))))
(setq vmergelist
(cons
(setq mlist
(list
(vl-position x rheights)
(vl-position pt lpxlist)
(1+ (vl-position x rheights))
(vl-position pt lpxlist)
)) vmergelist)
check T)

);if
(setq check nil mlist nil)
));lambda
(cdr rheights)
);mapcar
);lambda
lpxlist
colwidths
);mapcar
(setvar 'nomutt 0)
);progn
);if
(mapcar '(lambda (x)(entdel x)) linelist);;Delete all lines in selection set
;-------------------------------------- Table Creation and Info Placement----------------------------------------------;;Create table object
;;Fill table with gathered text and block info and set selected style.
;----------------------------------------------------------------------------------------------------------------------(princ "\nCreating Table...")
(setq tblobj
(vla-addtable
*Space* p0
(float (1- (length lpylist)))
(float (1- (length lpxlist)))
(apply 'max rowheights)
(apply 'max colwidths)))
(vla-put-regeneratetablesuppressed tblobj :vlax-true)
(princ "\nProcessing Text Info...")
(mapcar
'(lambda (x)
(vla-settext tblobj (caar x) (cadar x) (cadr x))
(vla-setcelltextheight tblobj (caar x) (cadar x) (caddr x))
)
tinfo
)
(princ "\nProcessing Block Info...")
(mapcar
'(lambda (x)
(vla-setcelltype tblobj (caar x) (cadar x) acBlockCell)
(vla-SetBlockTableRecordId tblobj (caar x) (cadar x) (cadr x) :vlax-false)
(mapcar '(lambda (y)
(vla-setblockattributevalue tblobj (caar x) (cadar x) (car y) (c
dr y)))
(nth 2 x))
(vla-SetBlockScale tblobj (caar x)(cadar x) (car (reverse x)))
)
binfo
)
(vla-put-StyleName tblObj kword)
(if (eq mergekword "Yes")
(progn
(princ "\nProcessing Merge Info")
;---------------------------------------- Method used to merge cells ---------------------------------------------------;For each list of cells to merge
;All cell content is combined and placed in the first cell
;The max cell text height found in the cells to merge is applied to the first ce

ll
;Cells are merged and content of first cell is displayed.
;-----------------------------------------------------------------------------------------------------------------------(mapcar
'(lambda (x / newstring cnumb thlist)
(setq newstring "" cnumb (1- (cadr x)))
(repeat (- (1+ (cadddr x)) (cadr x))
(setq newstring (strcat newstring (if (eq newstring "") "" " ") (vla-gett
ext tblobj (car x) (setq cnumb (1+ cnumb)))))
(if (/= (vla-gettext tblobj (car x) cnumb) "")
(setq thlist (cons (vla-getcelltextheight tblobj (car x) cnumb) thlis
t)))
)
(vla-settext tblobj (car x) (cadr x) newstring)
(if thlist (vla-setcelltextheight tblobj (car x)(cadr x)(apply 'max thlist)))
(vla-mergecells tblobj (car x) (caddr x) (cadr x) (cadddr x))
)
hmergelist
)
(mapcar
'(lambda (x / newstring rnumb thlist)
(setq newstring "" rnumb (1- (car x)))
(repeat (- (1+ (caddr x)) (car x))
(setq newstring (strcat newstring (if (eq newstring "") "" " ")(vla-gette
xt tblobj (setq rnumb (1+ rnumb)) (cadr x))))
(if (/= (vla-gettext tblobj rnumb (cadr x)) "")
(setq thlist (cons (vla-getcelltextheight tblobj rnumb (cadr x)) thlis
t)))
)
(vla-settext tblobj (car x) (cadr x) newstring)
(if thlist (vla-setcelltextheight tblobj (car x)(cadr x)(apply 'max thlist)))
(vla-mergecells tblobj (car x) (caddr x) (cadr x) (cadddr x))
)
vmergelist
)
));if
;-----------------------------------------------------------------------------------------------------------------------(setq i -1)
(mapcar
'(lambda (x)
(vla-setcolumnwidth tblobj (setq i (1+ i)) x)
)
colwidths
)
(setq i -1)
(mapcar
'(lambda (x)
(vla-setrowheight tblobj (setq i (1+ i)) x)
)
rowheights
)
(vla-put-regeneratetablesuppressed tblobj :vlax-false)
(vla-rotate tblobj p0 (- (* 2 pi) (getvar 'viewtwist)))
(princ "\nConversion Complete")
(mapcar '(lambda (x)(and x (not (vlax-object-released-p x))(vlax-release-object
x))) (list ssitem))

(setq *error* oerror)

(vla-EndUndoMark ActDoc)
(princ)
);defun