Capítulo 25.lsp

		;;;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?