;;;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 25. Visual LISP como cliente ActiveX.
(defun conecta-excel (/)
(setq apl-excel (vlax-get-or-create-object "Excel.Application")
col-libros (vlax-get-property apl-excel "Workbooks")
nom-libro (strcat (vl-filename-base (getvar "dwgname"))
".xls"))
(setq obj-libro (vl-catch-all-apply
'vlax-get-property
(list col-libros "Item" nom-libro)))
(cond
((vl-catch-all-error-p obj-libro)
(setq obj-libro (vlax-invoke-method col-libros "Add"))
(vlax-invoke-method
obj-libro
"SaveAs"
(strcat (getvar "dwgprefix") nom-libro) ; Nombre archivo
56 ; Formato archivo
"" ; Contraseña
"" ; Contraseña escritura
:vlax-false ; Abrir como Solo-Lectura
:vlax-false ; Crear copia de seguridad
1))) ; Acceso XlSaveAsAccessMode
(setq coleccion-hojas (vlax-get-property obj-libro "Sheets"))
(vla-put-visible apl-excel :vlax-true))
;;;Listado 25.1. Función conecta-excel.
(defun desconecta-excel ()
(vlax-release-object apl-excel)
(gc))
;;;Listado 25.2. Función desconecta-excel.
(defun apl-err (msj)
(if
(and apl-excel
(not (vlax-object-released-p apl-excel)))
(vlax-release-object apl-excel))
(prompt msj))
;;;Listado 25.3. Función apl-err.
(defun lista->excel (nombre lista / *error* celdas-excel hoja-1 coleccion-hojas
obj-libro nom-libro col-libros apl-excel)
(setq *error* apl-err)
(vl-load-com)
(conecta-excel)
(setq hoja-1 (vl-catch-all-apply
'vlax-get-property
(list coleccion-hojas "Item" nombre)))
(cond
((vl-catch-all-error-p hoja-1)
(setq hoja-1 (vlax-invoke-method coleccion-hojas "Add"))
(vlax-put-property hoja-1 "Name" nombre)))
(setq celdas-excel (vlax-get-property hoja-1 "Cells"))
(procesa-tabla lista)
(desconecta-excel))
;;;Listado 25.4. Función lista->excel.
(defun procesa-tabla (lista / numfila numcol)
(setq numfila 1
numcol 0)
(foreach campo (car lista)
(dato->celda
numfila
(setq numcol (1+ numcol))
(car campo)))
(while (setq fila (car lista))
(setq numfila (1+ numfila)
lista (cdr lista))
(procesa-fila fila numfila)))
;;;Listado 25.5. procesa-tabla function.
(defun procesa-fila (fila numfila / numcol)
(setq numcol 0)
(foreach campo fila
(dato->celda
numfila
(setq numcol (1+ numcol))
(cdr campo))))
;;;Listado 25.6. procesa-fila function.
(defun dato->celda (fila col valor)
(vlax-put-property
celdas-excel
"Item"
fila
col
(vl-princ-to-string valor)))
;;;Listado 25.7. dato->celda auxiliary function.
(defun C:EXCEL-ATRIBUTOS (/ lista-nombres)
(if (inicia-dialogo "atributos" "./dcl/atributos.dcl")
(progn
(if (setq lista-nombres (lee-bloques))
(llena-lista "lista_bloques" lista-nombres)
(set_tile "error"
"No hay bloques en el dibujo actual"))
(action_tile
"lista_bloques"
"(comprueba-atributos $value lista-nombres)")
(action_tile
"accept"
"(extrae (get_tile \"lista_bloques\") lista-nombres)")
(action_tile "cancel" "(done_dialog 0)")
(start_dialog)
(unload_dialog dcl_id)
(princ))))
;;;Listado 25.9. Función Principal C:EXCEL-ATRIBUTOS.
(defun llena-lista (comp-lista lista-nombres)
(start_list comp-lista)
(mapcar 'add_list
(mapcar '(lambda (term) (strcat (car term) "\t" (cdr term)))
lista-nombres))
(end_list))
;;;Listado 25.10. Función llena-lista function.
(defun comprueba-atributos (valor lista-nombres)
(if
(not
(equal (cdr (nth (atoi valor) lista-nombres)) "ATTRIB"))
(set_tile "error"
"El bloque seleccionado no posee atributos")
(set_tile "error" "")))
;;;Listado 25.11. Función comprueba-atributos
(defun extrae (valor lista-nombres / seleccion nombre)
(if lista-nombres
(setq seleccion (nth (atoi valor) lista-nombres)))
(if (= (cdr seleccion) "ATTRIB")
(progn (set_tile "error" "Procesando. Espere, por favor...")
(setq nombre (car seleccion))
(lista->excel nombre (sel-bloque nombre))
(done_dialog))))
;;;Listado 25.12. Función extrae
(defun lee-bloques (/ nombre lista)
(vlax-for obj
(vla-get-blocks *aevl:dibujo*)
(setq nombre (vla-get-name obj))
(if (and (not (wcmatch nombre "`**,*|*"))
(equal (vla-get-IsXref obj) :vlax-false))
(if (ssget "X" (list (cons 0 "INSERT") (cons 2 nombre)))
(setq lista (cons
(cons nombre
(if (tiene-atributos? obj)
"ATTRIB"
""))
lista)))))
(setq lista (vl-sort lista '(lambda (n1 n2) (< (car n1) (car n2)))))
lista)
;;;Listado 25.13. Función lee-bloques
(defun tiene-atributos? (obj-defbloque / resultado)
(vlax-for obj
obj-defbloque
(if
(equal (vla-get-ObjectName obj)
"AcDbAttributeDefinition")
(setq resultado t)))
resultado)
;;;Listado 25.14. Función tiene-atributos?
