Help with i lisp code that creates tables

[John.Red]

Hello to all! 

I've been following this forum and generally this site for a long time ago but I have just registered (my English is a bit poor to write topics and participate) because now i need your help with a lisp code that i found recently.

Below is the code, it creates tables from picked text objects. What i need is after you pick each text (before it goes to a cell) to change it's color to red (or any other color) because when I have a bunch of text objects I need to know which of them went to a table.

 

Can someone please help me with that?

 

Thanks in advance.

(defun c:AHxcol ( / pt1 numrows numcolumns rowheight colwidth ent doc curspace obj objtable col) 
(vl-load-com)
(setq doc (vla-get-activedocument (vlax-get-acad-object)))
(setq curspace (vla-get-modelspace doc))
; now do table 
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))
(setq numcolumns (getint "how many columns"))
(setq txtsz (getreal "enter text size"))

(setq numrows 2)
(setq rowheight (* 1.5 txtsz))
(setq colwidth (* 10 txtsz))
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "TABLE")
(setq x 1)
(repeat numcolumns
    (vla-settext objtable 1 (- x 1) (strcat "COLUMN " (rtos x 2 0)))
    (setq x (+ x 1))
)

(setq objtable (vlax-ename->vla-object (entlast)))
(vla-InsertRows objtable numrows txtsz 1)
(setq col 0)
(while (setq ent  (entsel "pick text object"))
    (setq obj (vlax-ename->vla-object (car ent)))
    (if (= (vla-get-objectname obj) "AcDbText")
        (progn
            (vla-settext objtable numrows col  (vla-get-textstring obj))
            (setq col (+ col 1))
            (if (= col numcolumns)
                (progn
                (setq col 0)
                (setq numrows (+ numrows 1))
                (vla-InsertRows objtable numrows (* txtsz 1.5) 1)
                )
            )
        )
    )
)
(vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) txtsz)
(vla-SetAlignment objtable acDataRow acMiddleCenter)
(vlax-release-object objtable)
(princ)
)

(c:AHxcol)

 

Edited June 15, 2022 by SLW210
Added Code Tags!

[SLW210]

Please use Code Tags for your Code in the future.

[John.Red]

Sorry, i didn't know how to do it, next time i will. 

[mhupp]

try this.

 

(defun c:AHxcol (/ k txtsz x pt1 numrows numcolumns rowheight colwidth ent doc curspace obj objtable col)
  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq curspace (vla-get-modelspace doc))
  ; now do table 
  (setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))
  (setq numcolumns (getint "Number of columns: "))
  (setq txtsz (getreal "Text size: "))
  (setq numrows 2)
  (setq rowheight (* 1.5 txtsz))
  (setq colwidth (* 10 txtsz))
  (setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
  (vla-settext objtable 0 0 "TABLE")
  (setq x 0)
  (repeat numcolumns
    (vla-settext objtable 1 x (strcat "COLUMN " (itoa (setq x (1+ x)))))
  )
  (setq objtable (vlax-ename->vla-object (entlast)))
  (vla-InsertRows objtable numrows txtsz 1)
  (setq col 0)
  (while (setq ent (car (entsel "Pick text :")))
    (if (= (vla-get-objectname (setq obj (vlax-ename->vla-object ent))) "AcDbText")
      (progn
        (vla-put-color obj 1)
        (vla-settext objtable numrows col (vla-get-textstring obj))
        (setq col (+ col 1))
        (if (= col numcolumns)
          (progn
            (setq col 0)
            (setq numrows (+ numrows 1))
            (vla-InsertRows objtable numrows (* txtsz 1.5) 1)
          )
        )
      )
    )
  )
  (vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) txtsz)
  (vla-SetAlignment objtable acDataRow acMiddleCenter)
  (setq x 0)
  (repeat numcolumns
    (if (/= (vla-gettext objtable numrows x) "") (setq k 1))
    (setq x (1+ x))
  )
  (if (eq k 1)
    (progn)
    (vla-deleterows objtable numrows numrows)
  )
  (vlax-release-object objtable)
  (princ)
)

 

-edit

@John.Red update the code to delete the last row if nothing is inputted (aka blank)

Edited June 15, 2022 by mhupp
Code Updated

[John.Red]

My friend you are awesome! Thank you so much for your effort, this is exactly what i want.  

[John.Red]

I have updated the code, better now that i don't have to delete the last row.

Works perfectly, thanks again.

 

May i ask, is it possible to pick values from an existing table?

 

I have many tables where i want to copy certain rows to a new table. What i do now with this lisp (and your help on it) is to copy all these tables, double explode to get values as plain text and then make a table by the lisp (with same columns) and pick each text from a row.

 

It could be time saver if i could pick these values directly from the tables instead of copy-explode-explode. If cannot be done is ok, i can do my job with the above method, but if is something that can be done "easily" it could be a great help.

 

Thanks again for your effort.

[mhupp]

Yes using but i can't get them to turn red. I'm sure your fine with that.

 

(defun c:AHxcol (/ k txtsz x pt1 numrows numcolumns rowheight colwidth ent doc curspace obj objtable col)
  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq curspace (vla-get-modelspace doc))
  ; now do table 
  (setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))
  (setq numcolumns (getint "Number of columns: "))
  (setq txtsz (getreal "Text size: "))
  (setq numrows 2)
  (setq rowheight (* 1.5 txtsz))
  (setq colwidth (* 10 txtsz))
  (setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
  (vla-settext objtable 0 0 "TABLE")
  (setq x 0)
  (repeat numcolumns
    (vla-settext objtable 1 x (strcat "COLUMN " (itoa (setq x (1+ x)))))
  )
  (setq objtable (vlax-ename->vla-object (entlast)))
  (vla-InsertRows objtable numrows txtsz 1)
  (setq col 0)
  (while (setq ent (car (nentsel "Pick text : ")))
    (if (member (vla-get-objectname (setq obj (vlax-ename->vla-object ent))) '("AcDbMText" "AcDbText"))
      (progn
        (vla-put-color obj 1)
        (vla-settext objtable numrows col (vla-get-textstring obj))
        (setq col (1+ col))
        (if (= col numcolumns)
          (progn
            (setq col 0)
            (setq numrows (1+ numrows))
            (vla-InsertRows objtable numrows (* txtsz 1.5) 1)
          )
        )
      )
    )
  )
  (vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) txtsz)
  (vla-SetAlignment objtable acDataRow acMiddleCenter)
  (setq x -1)
  (repeat numcolumns
    (if (/= (vla-gettext objtable numrows (setq x (1+ x))) "") (setq k 1))    
  )
  (if (eq k 1)
    (progn)
    (vla-deleterows objtable numrows numrows)
  )
  (vlax-release-object objtable)
  (princ)
)

 

[John.Red]

It keeps asking for a text object. When i pick a cell the command ends and leaves a blank table.

[John.Red]

Oops, sorry. I thought you changed the code to use cells instead text. Don't mind, i can work with this lisp as it is.

[mhupp]

4 minutes ago, John.Red said:

Oops, sorry. I thought you changed the code to use cells instead text. Don't mind, i can work with this lisp as it is.

 

nope just added an n to entsel to make nentsel so you can select nested text inside tables or blocks.

[John.Red]

Oh, i see.. Is more important though to know which text i have selected (by turning red) to be sure that everything i want is on the new table than picking from a set of tables. I will stick to copy-exploding method to extract the info i want. 

 

Thank you! 

[mhupp]

1 hour ago, John.Red said:

Oh, i see.. Is more important though to know which text i have selected (by turning red) to be sure that everything i want is on the new table than picking from a set of tables.

 

Try this. works on text, mtext and tables

 

;;----------------------------------------------------------------------------;;
;; CREATE TABLE AND ADD SELECTED TEXT TO IT
(defun c:AHxcol (/ k txtsz x pt1 numrows numcolumns rowheight colwidth ent doc curspace obj objtable col)
  (vl-load-com)
  (setq doc (vla-get-activedocument (vlax-get-acad-object)))
  (setq curspace (vla-get-modelspace doc))
  ; now do table 
  (setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))
  (setq numcolumns (getint "Number of columns: "))
  (setq txtsz (getreal "Text size: "))
  (setq numrows 2)
  (setq rowheight (* 1.5 txtsz))
  (setq colwidth (* 10 txtsz))
  (setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
  (vla-settext objtable 0 0 "TABLE")
  (setq x 0)
  (repeat numcolumns
    (vla-settext objtable 1 x (strcat "COLUMN " (itoa (setq x (1+ x)))))
  )
  (setq objtable (vlax-ename->vla-object (entlast)))
  (vla-InsertRows objtable numrows txtsz 1)
  (setq col 0)
  (while (setq ent (entsel "Pick text : "))
    (cond
      ((member (vla-get-objectname (setq obj (vlax-ename->vla-object (car ent)))) '( "AcDbMText" "AcDbText"))
        (progn
          (vla-put-color obj 1)
          (vla-settext objtable numrows col (vla-get-textstring obj))
          (setq col (1+ col))
          (if (= col numcolumns)
            (progn
              (setq col 0)
              (setq numrows (1+ numrows))
              (vla-InsertRows objtable numrows (* txtsz 1.5) 1)
            )
          )
        )
      )
      ((eq (vla-get-objectname (setq obj (vlax-ename->vla-object (car ent)))) "AcDbTable")
        (setq x (_hit-test (cadr ent) obj))
        (setq COLOBJ (vla-getinterfaceobject (vlax-get-acad-object) "AutoCAD.AcCmColor.16"))
        (vla-put-colorindex COLOBJ 1)
        (vla-SetCellContentColor obj (car x) (cadr x) COLOBJ)
        (vla-settext objtable numrows col (vla-getText obj (car x) (cadr x)))
        (setq col (1+ col))
        (if (= col numcolumns)
          (progn
            (setq col 0)
            (setq numrows (1+ numrows))
            (vla-InsertRows objtable numrows (* txtsz 1.5) 1)
          )
        )
      )
    )
  )
  (vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) txtsz)
  (vla-SetAlignment objtable acDataRow acMiddleCenter)
  (setq x -1)
  (repeat numcolumns
    (if (/= (vla-gettext objtable numrows (setq x (1+ x))) "") (setq k 1))
  )
  (if (eq k 1)
    (progn)
    (vla-deleterows objtable numrows numrows)
  )
  (vlax-release-object objtable)
  (princ)
)
;;----------------------------------------------------------------------------;;
;; FIND ROW AND COLUMN OF SELECTED TEXT IN TABLE
(defun _hit-test (pt obj / vd)
  (setq pt (vlax-3D-point (trans pt 1 0))
        vd (vlax-3D-point (trans (getvar 'VIEWDIR) 1 0))
  )
  (if (eq :vlax-true (vla-hittest obj pt vd 'r 'c))
    (list r c)
  )
)