;;;Código fuente del libro "Experto AutoCAD con Visual LISP"
;;; (c) 2012 Ediciones ARTUAL, S.L. Barcelona, España.
;;; (c) 2012-2020 Reinaldo Togores. Todos los derechos reservados
;;; Se permite su uso mencionando la obra y su autor.
;;;Capítulo 24. Tablas.
(defun ins-tabla (/ pt altura-fila ancho-col nfilas ncols)
(setq pt (getpoint "\nEsquina superior izquierda de la tabla: ")
altura-fila (getdist pt "\nAltura de filas: ")
ancho-col (getdist pt "\nAnchura de columnas: ")
nfilas (getint "\nNúmero de filas: ")
ncols (getint "\nNúmero de columnas: "))
(vla-AddTable
(espacio-actual *aevl:dibujo*)
(vlax-3d-point pt)
nfilas
ncols
altura-fila
ancho-col))
;;;Listado 24.1. Función que inserta una tabla en el dibujo.
(defun altura-texto-fila (obj-tabla i-fila altura-texto /)
(setq i 0)
(repeat (vla-get-Columns obj-tabla)
(vla-setTextHeight2 obj-tabla i-fila i 0 altura-texto)
(setq i (1+ i))))
;;;Listado 24.2. Función que cambia la altura de texto de una fila.
(defun altura-texto-columna (obj-tabla i-col altura-texto /)
(setq i 0)
(repeat (vla-get-Rows obj-tabla)
(vla-setTextHeight2 obj-tabla i i-col 0 altura-texto)
(setq i (1+ i))))
;;;Listado 24.3. Función que cambia la altura de texto para una columna.
(defun sel-bloque (nombre / ss obj cont ename datos lista-datos)
(setq cont 0)
(if
(setq ss (ssget "X"
(list (cons 0 "INSERT") (cons 2 nombre))))
(while (setq ename (ssname ss cont))
(setq obj (vlax-ename->vla-object ename))
(setq datos (list
(cons "CAPA" (vla-get-layer obj))
(cons "COORDS"
(vlax-safearray->list
(vlax-variant-value
(vla-get-insertionpoint obj))))))
(setq lista-datos (cons
(append datos
(ax-lee-atributos ename))
lista-datos))
(setq cont (1+ cont))))
lista-datos)
;;;Listado 24.4. Selección del bloque a procesar y extracción de sus atributos a una lista.
(defun col-w (lista-datos ncols / lst-w max-c)
(setq lst-w (mapcar
'(lambda (fila)
(mapcar
'(lambda (cel)
(apply
'max
(list
(strlen
(vl-princ-to-string (car cel)))
(strlen
(vl-princ-to-string (cdr cel))))))
fila))
lista-datos)
i 0)
(repeat ncols
(setq max-c (cons
(apply 'max
(mapcar '(lambda (x) (nth i x)) lst-w))
max-c))
(setq i (1+ i)))
(reverse max-c))
;;;Función que calcula los anchos relativos aproximados de las columnas.
(defun C:TABLA-ATRIBUTOS (/ *error* pres-act bloque nombre car-por-cols ancho-por-car
lista-datos nfilas ncols pt-ins pt-esquina altura-fila
ancho-tabla obj-tabla i j txt)
(vla-StartUndoMark *aevl:dibujo*)
(defun *error* (msg)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U")
(prompt msg))
(if (/= (setq pres-act (getvar "CTAB")) "Model")
(setvar "TILEMODE" 1))
(while
(not
(and (setq bloque (ssget "_:S" '((0 . "INSERT"))))
(equal
(vla-get-HasAttributes
(vlax-ename->vla-object (ssname bloque 0)))
:vlax-true)))
(prompt "\nSelect a bloque with attributes: "))
(setq nombre (cdr (assoc 2 (entget (ssname bloque 0))))
lista-datos (sel-bloque nombre)
nfilas (length lista-datos)
ncols (length (car lista-datos)))
(setvar "CTAB" pres-act)
(initget 1)
(setq pt-ins (getpoint "\nSpecify table insertion point: "))
(initget (+ 1 32))
(setq pt-esquina (getcorner pt-ins "\nSpecify table size: ")
altura-fila (/
(abs (- (nth 1 pt-ins) (nth 1 pt-esquina)))
(1+ nfilas))
ancho-tabla (abs (- (nth 0 pt-esquina) (nth 0 pt-ins)))
obj-tabla ; Creación de la tabla
(vla-AddTable
(espacio-actual *aevl:dibujo*)
(vlax-3d-point pt-ins)
(1+ nfilas)
ncols
altura-fila
(/ ancho-tabla ncols)))
(vla-put-RegenerateTableSuppressed
obj-tabla
:vlax-true)
;;Las anchuras de columna se ajuatan a los contenidos
(setq car-por-cols (col-w lista-datos ncols)
ancho-por-car (/
ancho-tabla
(apply '+ car-por-cols))
i 0)
(foreach w car-por-cols
(vla-SetColumnWidth obj-tabla i (* ancho-por-car w))
(setq i (1+ i)))
(vla-SetText obj-tabla 0 0 nombre) ; Título
(setq i 0)
(foreach dato (car lista-datos)
(vla-SetText obj-tabla 1 i (car dato)) ; Cabecera
(setq i (1+ i)))
(setq i 0)
(repeat (1- nfilas) ; Filas de datos
(setq j 0)
(repeat ncols
(vla-SetCellAlignment
obj-tabla
(+ i 2)
j
acMiddleCenter)
(setq txt (vl-princ-to-string
(cdr (nth j (nth i lista-datos)))))
(vla-SetText obj-tabla (+ i 2) j txt)
(setq j (1+ j)))
(setq i (1+ i)))
(vla-put-RegenerateTableSuppressed
obj-tabla
:vlax-false)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 24.5. Función principal C:TABLA-DATOS.
