;; © 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-insertionpoint vlaobj))) 0 1)
        rpos (1- (vl-position (cadr pos)(vl-sort (cons (cadr pos) lpylist) '>)))
        cpos (1- (vl-position (car pos) (vl-sort (cons (car pos) lpxlist) '<))))
(if (setq expos (vl-position (list rpos cpos) (mapcar '(lambda (x)(list (car (car 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, attributetextstring 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-insertionpoint obj))) 0 1)
        rpos (1- (vl-position (cadr pos)(vl-sort (cons (cadr pos) lpylist) '>)))
        cpos (1- (vl-position (car pos) (vl-sort (cons (car pos) 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 lpylist  tinfo     cwidths     check        tstyle     spos
                       tstylelst hmergelist vmergelist blocklist  rowheights selsets       tstylelst2 tstylelst3
                       kword     linelist       binfo        rheights     ssitem   tblobj)
                
(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)'("PaperSpace" "ModelSpace")))
         tstylelst (acad_strlsort
                       (vlax-for i
                         (setq tstyle (vla-item (vla-get-dictionaries ActDoc) "ACAD_TABLESTYLE"))
                         (setq tstylelst (cons (vla-get-name i) tstylelst))))
         i -1)

(vla-EndUndoMark ActDoc)
(vla-StartUndoMark ActDoc)

(if (= (length tstylelst) 1)(setq kword (car tstylelst))
(progn
(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 " ]:<Standard>"))) kword "Standard"))
(setq kword (nth (vl-position kword tstylelst2) tstylelst))
));
(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)) lpylist)))(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)
(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 merged cells.
;For each column, a selection is attempted at each horizontal line at column's center.
;If no selection is made, the point is at the center or upper region of vertically 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 for 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-position 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 1 lpylist) lpylist)
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 lpylist) 0.0) (* pi 1.5) x)))
    (if (zerop (vla-get-count ssitem))
         (if check
           (setq vmergelist (replace vmergelist 0 (replace mlist 2 (1+ (vl-position 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
   rheights
  );mapcar
);lambda
lpxlist
colwidths
);mapcar
(setvar 'nomutt 0)
);progn
(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-TitleSuppressed tblobj :vlax-true)
(vla-put-HeaderSuppressed tblobj :vlax-true)
(Vla-unmergecells tblobj 0 0 0 (length 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) (cdr y)))
                (nth 2 x))
   (vla-SetBlockScale tblobj (caar x)(cadar x) (car (reverse x)))
 )
 binfo
)

 (vla-put-StyleName tblObj kword)


(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 cell
;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-gettext tblobj (car x) (setq cnumb (1+ cnumb)))))
       (if (/= (vla-gettext tblobj (car x) cnumb) "")
           (setq thlist (cons (vla-getcelltextheight tblobj (car x) cnumb) thlist)))
    )
   (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-gettext tblobj (setq rnumb (1+ rnumb)) (cadr x))))
       (if (/= (vla-gettext tblobj rnumb (cadr x)) "")
          (setq thlist (cons (vla-getcelltextheight tblobj rnumb (cadr x)) thlist)))
    )
   (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
)
)
;-------------------------------------------------------------------------------------------------------------------------
(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