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