Código Fuente‎ > ‎

Capítulo 23.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 23. Medios de asociar información a los Objetos Gráficos.

(defun ent-lee-atributos (noment / ent lista txt) 
  (setq ent (entget noment))
  (if 
    (and (equal (cdr (assoc 0 ent)) "INSERT") 
         (> (cdr (assoc 66 ent)) 0))
    (progn (setq ent (entget (entnext noment))) 
           (while (not (= (cdr (assoc 0 ent)) "SEQEND")) 
             (foreach dato ent 
               (if (or (= (car dato) 1) (= (car dato) 3)) 
                 (setq txt (cons (cdr dato) txt))))
             (setq lista (cons 
                           (cons (cdr (assoc 2 ent)) 
                                 (sustituye 
                                   ""
                                   "\\P"
                                   (apply 'strcat (reverse txt))))
                           lista)
                   ent   (entget (entnext (cdr (assoc -1 ent))))))))
  (reverse lista))
;;;Listado 23.1. Función que lee los atributos variables de un bloque.

(defun prp-lee-atributos (ename / ent lista txt) 
  (setq ent (entget ename))
  (if 
    (and (equal (cdr (assoc 0 ent)) "INSERT") 
         (> (cdr (assoc 66 ent)) 0))
    (progn 
      (setq ent (entnext ename))
      (while (not (= (cdr (assoc 0 (entget ent))) "SEQEND")) 
        (setq valor (getpropertyvalue ent "Value")
              lista (cons 
                      (cons (getpropertyvalue ent "Tag") 
                            (if (vl-string-search "\\P" valor) 
                              (sustituye " " "\\P" valor)
                              valor))
                      lista)
              ent   (entnext ent)))))
  (reverse lista))
;;;Listado 23.2. Función no-Com que lee los atributos variables de un bloque.

(defun ax-extrae-atrib (bloque constante / atributos lista) 
  (setq atributos (vlax-variant-value 
                    (if constante 
                      (vla-getconstantattributes bloque)
                      (vla-getattributes bloque))))
  (if (>= (vlax-safearray-get-u-bound atributos 1) 0) 
    (foreach atrib (vlax-safearray->list atributos) 
      (setq lista (cons 
                    (cons (vlax-get-property atrib "TagString") 
                          (if 
                            (= (vla-get-MTextAttribute atrib) 
                               :vlax-true)
                            (sustituye 
                              ""
                              "\\P"
                              (vlax-get-property atrib "TextString"))
                            (vlax-get-property atrib "TextString")))
                    lista))))
  lista)
;;;Listado 23.3. Función estándar para extraer valores de atributos.

(defun ax-lee-atributos (noment / bloque resultado) 
  (setq bloque (vlax-ename->vla-object noment))
  (setq resultado (vl-catch-all-apply 
                    'vla-get-HasAttributes
                    (list bloque)))
  (if (eq resultado :vlax-true) 
    (append (reverse (ax-extrae-atrib bloque t)) 
            (reverse (ax-extrae-atrib bloque nil)))))
;;;Listado 23.4. Procesamiento de un bloque para extraer una lista con sus atributos.

(defun ent-datosx (noment nomaplic lis-id lis-val / datos lista objeto) 
  (if (not (tblsearch "appid" nomaplic)) 
    (regapp nomaplic))
  (setq datos (list 
                -3
                (cons nomaplic 
                      (foreach term (mapcar 'strcat lis-id lis-val) 
                        (setq lista (append lista 
                                            (list (cons 1000 term))))))))
  (setq objeto (append (entget noment) (list datos)))
  (entmod objeto))
;;;Listado 23.5. Asignación de XDATA.

(defun ent-lee-datosx (noment nomaplic id como-cadena / val) 
  (setq id  (strcat id "=*")
        val (cdar 
              (vl-remove-if-not 
                '(lambda (x) (wcmatch (cdr x) id))
                (cdadr (assoc -3 (entget noment (list nomaplic)))))))
  (if val 
    (progn (setq val (vl-string-left-trim id val)) 
           (if como-cadena 
             val
             (read val)))))
;;;Listado 23.6. Lectura de XDATA.

(defun lista-dicc () 
  (mapcar 'cdr 
          (vl-remove-if-not 
            '(lambda (x) (= (car x) 3))
            (entget (namedobjdict)))))
;;;Listado 23.7. Obtención de  la lista de todos los diccionarios.

(defun entrada-datos (/ ent nombre lista) 
  (while 
    (and (setq ent (car (entsel "\nDesigne entidad a nombrar: "))) 
         (setq nombre (getstring t "\nIndique Nombre: "))
         (not (= nombre "")))
    (setq lista (cons (cons (cdr (assoc 5 (entget ent))) nombre) 
                      lista)))
  lista)
;;;Listado 23.8. Función para solicitar los datos al usuario.

(defun crea-dicc (nombre) 
  (if (not (member nombre (lista-dicc))) 
    (dictadd (namedobjdict) 
             nombre
             (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary"))))
    (cdr (assoc -1 (dictsearch (namedobjdict) nombre)))))
;;;Listado 23.9. Función que crea el diccionario o recupera su ENAME en caso de existir.

(defun nuevos-registros (ent-dicc lista-datos / xrec) 
  (foreach dato lista-datos 
    (if (dictsearch ent-dicc (car dato)) 
      (entdel (dictremove ent-dicc (car dato))))
    (if 
      (setq xrec (entmakex 
                   (list '(0 . "XRECORD") 
                         '(100 . "AcDbXrecord")
                         (cons 1 (cdr dato)))))
      (dictadd ent-dicc (car dato) xrec)
      (prompt "\error en adición de campo"))))
;;;Listado 23.10. Adición de nuevos registros al diccionario.

(defun C:TOPONIMICOS (/ datos dicc) 
  (cond 
    ((setq dicc (dictsearch (namedobjdict) "TOPONIMICOS"))
     (setq dicc (cdr (assoc -1 dicc))))
    ((setq dicc (crea-dicc "TOPONIMICOS")))
    (t
     (prompt "\nError en la creación del diccionario TOPONOIMICOS")))
  (if (and dicc (setq datos (entrada-datos))) 
    (nuevos-registros dicc datos)
    (alert "Se ha producido un error en la aplicación"))
  (princ))
;;;Listado 23.11. Comando C:TOPONIMICOS.

(defun C:IDENTIFICA (/ dicc ent nom) 
  (if 
    (and (setq dicc (dictsearch (namedobjdict) "TOPONIMICOS")) 
         (setq dicc (cdr (assoc -1 dicc))))
    (while (setq ent (car (entsel "\nDesigne entidad a identificar: "))) 
      (if (setq nom (dictsearch dicc (cdr (assoc 5 (entget ent))))) 
        (alert 
          (strcat "La entidad seleccionada representa\n" 
                  (cdr (assoc 1 nom))))
        (alert "La entidad no tiene\nnombre asignado.")))))
;;;Listado 23.12. Función para consulta de los datos asociados.

(defun C:BORRA-NOMBRE (/ dicc ent) 
  (if 
    (and (setq dicc (dictsearch (namedobjdict) "TOPONIMICOS")) 
         (setq dicc (cdr (assoc -1 dicc))))
    (setq ent (car 
                (entsel 
                  "\nSeleccione la entidad cuyo nombre desea eliminar: "))))
  (setq ent (cdr (assoc 5 (entget ent))))
  (if (dictsearch dicc ent) 
    (entdel (dictremove dicc ent))
    (alert "La entidad no tiene\nnombre asignado.")))
;;;Listado 23.12a. Función que elimina el toponímico asociado.

(defun lista->ldata (dicc lista) 
  (foreach sublista lista 
    (if (listp sublista) 
      (vlax-ldata-put 
        dicc
        (vl-princ-to-string (car sublista))
        (cdr sublista)))))
;;;Listado 23.13. Función lista->ldata.

(defun lista->ldata (dicc lista) 
  (foreach sublista lista 
    (if (and (listp sublista) (vlax-ldata-test (cdr sublista))) 
      (vlax-ldata-put 
        dicc
        (vl-princ-to-string (car sublista))
        (cdr sublista)))))
;;;Listado 23.14. Función LISTA->LDATA incorporando VLAX-LDATA-TEST.

(defun asocia (ent-ppal ent-asoc clave) 
  (vlax-ldata-put ent-ppal clave ent-asoc))
;;;Listado 23.15. Función para asociar entidades mediante LDATA.

(defun localiza-ADO-CAO (/ dir lcid versCAOdir ADOdir)
  (setq dir    (getenv "COMMONPROGRAMFILES")
        ADOdir (findfile (strcat dir "\\system\\ado\\msado15.dll"))
        lcid   (vla-get-LocaleID (vlax-get-acad-object))
        vers   (if (> (atoi (getvar "ACADVER")) 19) 
                 "20"
                 "16")
        CAOdir (findfile 
                 (strcat 
                   dir
                   "\\AUTODESK SHARED\\"
                   (cond 
                     ((= lcid 1028) (strcat "cao" vers "cht.tlb"))
                     ((= lcid 1029) (strcat "cao" vers "csy.tlb"))
                     ((= lcid 1031) (strcat "cao" vers "deu.tlb"))
                     ((= lcid 1034) (strcat "cao" vers "esp.tlb"))
                     ((= lcid 1036) (strcat "cao" vers "fra.tlb"))
                     ((= lcid 1038) (strcat "cao" vers "hun.tlb"))
                     ((= lcid 1040) (strcat "cao" vers "ita.tlb"))
                     ((= lcid 1041) (strcat "cao" vers "jpn.tlb"))
                     ((= lcid 1042) (strcat "cao" vers "kor.tlb"))
                     ((= lcid 1046) (strcat "cao" vers "ptb.tlb"))
                     ((= lcid 1049) (strcat "cao" vers "rus.tlb"))
                     ((= lcid 2052) (strcat "cao" vers "chs.tlb"))
                     (t (strcat "cao" vers "enu.tlb"))))))
  (list ADOdir CAOdir))
;;;Listado 23.16. Función que busca las trayectorias de las bibliotecas.

(defun importa-ADO-CAO (/ bibl) 
  (vl-load-com)
  (setq bibl (localiza-ADO-CAO))
  (if (car bibl) 
    (cond 
      ((vl-member-if 
         '(lambda (x) (wcmatch x "ADOM-*"))
         (atoms-family 1))
       t)
      (t
       (vlax-import-type-library 
         :tlb-filename
         (car bibl)
         :methods-prefix
         "adoM-"
         :properties-prefix
         "adoP-"
         :constants-prefix
         "adoC-")))
    (prompt "\nERROR: No se encontró la biblioteca ADO"))
  (if (last bibl) 
    (cond 
      ((vl-member-if 
         '(lambda (x) (wcmatch x "CAOM-*"))
         (atoms-family 1))
       t)
      (t
       (vlax-import-type-library 
         :tlb-filename
         (last bibl)
         :methods-prefix
         "caoM-"
         :properties-prefix
         "caoP-"
         :constants-prefix
         "caoC-")))
    (prompt "\nERROR: No se encontró la biblioteca CAO.")))
;;;Listado 23.16. Función que importa bibliotecas de componentes.