;;;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 11. Seleccionar Entidades
(defun similar (lista-ent / )
(ssget "X"
(list (assoc 0 lista-ent)
(assoc 8 lista-ent)
(if (assoc 67 lista-ent)
(assoc 67 lista-ent)
'(67 . 0))
(if (assoc 62 lista-ent)
(assoc 62 lista-ent)
'(62 . 256))
(if (assoc 6 lista-ent)
(assoc 6 lista-ent)
'(6 . "BYLAYER"))
(assoc 410 lista-ent))))
;;;Listado 11.1. Selección de entidades con propiedades similares.
(defun C:BORRA-SIMILAR ()
(vl-cmdf
"._erase"
(similar
(entget
(car (entsel "\nDesigne objeto para borrar los similares: "))))
"")
(princ))
;;;Listado 11.2. Comando para borrar todos los objetos similares al designado.
(defun sel-area (obj clave eiz esd)
(ssget "X"
(list (cons 0 obj)
(cons 410 (getvar "ctab"))
'(-4 . ">,>,*")
(cons clave eiz)
'(-4 . "<,<,*")
(cons clave esd))))
;;;Listado 11.3. Selección por área rectangular.
(defun sel-area-multiclave (obj capa lista-clave eiz esd)
(ssget
"X"
(append
(list (cons 0 obj) (cons 8 capa) (cons 410 (getvar "ctab")))
(append '((-4 . "<OR"))
(apply 'append
(mapcar '(lambda (x)
(list '(-4 . "<AND")
'(-4 . ">,>,*")
(cons x eiz)
'(-4 . "<,<,*")
(cons x esd)
'(-4 . "AND>")))
lista-clave))
'((-4 . "OR>"))))))
;;;Listado 11.4. Selección por área usando claves múltiples.
(defun sel-fuera (obj clave eiz esd)
(ssget "X"
(list (cons 0 obj)
(cons 410 (getvar "ctab"))
'(-4 . "<OR")
'(-4 . "<XOR") ;_ condición para la coord x
'(-4 . ">,*,*")
(cons clave eiz)
'(-4 . "<,*,*")
(cons clave esd)
'(-4 . "XOR>")
'(-4 . "<XOR") ;_ condición para la coord y
'(-4 . "*,>,*")
(cons clave eiz)
'(-4 . "*,<,*")
(cons clave esd)
'(-4 . "XOR>")
'(-4 . "OR>"))))
;;;Listado 11.5. Selección de todos los objetos fuera de un área rectangular.
(defun C:DEMO-SEL-AREA (/ *error* ant-color dentro sel eiz esd)
(vl-cmdf "._UNDO" "_Begin")
(cmd-entrar)
(setq ant-color (getvar "CECOLOR"))
(initget 1 "Dentro Fuera")
(if (= (getkword "\nSeleccionar [Dentro/Fuera]: ") "Dentro")
(setq dentro t))
(setvar "cecolor" "5")
(vl-cmdf "._zoom" "_w" '(0.0 0.0) '(297.0 210.0))
(vl-cmdf "._circle" '(10.0 10.0) 2.5)
(vl-cmdf "._array" (entlast) "" "_r" 20 25 10.0 10.0)
(prompt "\nDesigne zona para la selección: ")
(setq eiz (getpoint "\nEsquina inferior izquierda: ")
esd (getcorner eiz "\nEsquina superior derecha: "))
(if (apply 'and (mapcar '<= eiz esd))
(progn
(getstring
"\nPresione una tecla para dejar un sólo círculo visible: ")
(vl-cmdf "._zoom" "_w" '(5.0 5.0) '(15.0 15.0))
(alert "Seleccionando círculos no visibles y cambiando color...")
(setq sel (if dentro
(sel-area "CIRCLE" 10 eiz esd)
(sel-fuera "CIRCLE" 10 eiz esd)))
(vl-cmdf "._change" sel "" "_p" "_c" 1 "")
(getstring
"\nPresione una tecla para regresar a la vista anterior: ")
(vl-cmdf "._zoom" "_p")
(alert (strcat (itoa (sslength sel))
" círculos seleccionados cambiados a rojo"))
(cmd-salir)
(setvar "CECOLOR" ant-color)
(vl-cmdf "._UNDO" "_End"))
(progn (vl-cmdf "._UNDO" "_Back")
(prompt "\nError en tiempo de ejecución!")))
(princ))
;;;Listado 11.6. Demostración de las funciones de selección por un área rectangular.
(defun ss+ (/ conj-sel tmp)
(setvar "grips" 2) ; 2010 o anterior:(setvar "grips" 1)
(setq conj-sel (ssadd))
(while (setq tmp (entsel "\nSeleccione entidad a añadir: "))
(ssadd (car tmp) conj-sel)
(sssetfirst nil conj-sel))
conj-sel)
;;;Listado 11.7. Demostración de SSADD.
(defun ss++ (/ conj-sel tmp agregar)
(cmd-entrar)
(setvar "grips" 2)
(setq conj-sel (ssadd)
agregar t)
(initget "Quitar")
(while (setq tmp (getpoint (strcat "\nSelect entity to "
(if agregar
"agregar[Quitar]: "
"quitar[Agregar]: "))))
(cond ((listp tmp)
(if (setq tmp (ssget tmp))
(progn (apply (if agregar
'ssadd
'ssdel)
(list (ssname tmp 0) conj-sel))
(sssetfirst nil conj-sel))))
((= tmp "Quitar") (setq agregar nil))
(t (setq agregar t)))
(initget (if agregar
"Quitar"
"Agregar")))
(cmd-salir)
(cdr (sssetfirst nil conj-sel)))
;;;Listado 11.8. Construcción de un conjunto de selección agregando y quitando entidades.
(defun ss->ax-ss (conj-sel sel-nombre sel-coll / sel)
(if (vl-catch-all-error-p
(setq sel
(vl-catch-all-apply 'vla-add (list sel-coll sel-nombre))))
(vla-clear (setq sel (vla-item sel-coll sel-nombre))))
(vla-additems sel (ss->matriz conj-sel))
(vla-item sel-coll sel-nombre))
;;;Listado 11.9. Transformación de un PICKSET en SelectionSet.
(defun ss->matriz (conj-sel / indice matriz)
(setq indice 0
matriz (vlax-make-safearray
vlax-vbObject
(cons 0 (1- (sslength conj-sel)))))
(repeat (sslength conj-sel)
(vlax-safearray-put-element
matriz
indice
(vlax-ename->vla-object (ssname conj-sel indice)))
(setq indice (1+ indice)))
(vlax-make-variant matriz))
;;;Listado 11.10. Agregar objetos de un PICKSET a una matriz.
(defun VxSsetFilter (Filtro)
(mapcar '(lambda (Tipo Dato) (VxListToArray Tipo Dato))
(list vlax-vbInteger vlax-vbVariant)
(list (mapcar 'car Filtro) (mapcar 'cdr Filtro))))
;;;Listado 11.11. Creación automática de filtros de selección ActiveX (Jürg Menzi).
;;; ©2002 MENZI ENGINEERING GmbH, Switzerland. <http://www.menziengineering.ch/>
(defun VxListToArray (Tipo Lista)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray Tipo (cons 0 (1- (length Lista))))
Lista)))
;;;Listado 11.12. Función VxListToArray (Jürg Menzi).
;;; ©2002 MENZI ENGINEERING GmbH, Switzerland. <http://www.menziengineering.ch/>
(defun ax-sel-borde (conj-sel point-list lista-filtro)
(apply 'vla-SelectByPolygon
(append (list conj-sel
acSelectionSetFence
(ax-lista->matriz (apply 'append point-list)))
(VxSsetFilter lista-filtro))))
;;;Listado 11.13. Selección del tipo BORDE con ActiveX.
(defun ax-lista->variant (lista)
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbObject
(cons 0 (1- (length lista))))
lista)))
;;;Listado 11.14. Conversión de la lista en matriz.
(defun ax-no-grupo (lista-obj obj-grupo / tmp)
(vlax-for obj obj-grupo
(setq tmp (cons (vla-get-handle obj) tmp)))
(foreach obj lista-obj
(if (member (vla-get-handle obj) tmp)
(setq lista-obj (vl-remove obj lista-obj))))
lista-obj)
;;;Listado 11.15. Función para detectar y eliminar objetos pertenecientes a un Grupo.
(defun ax-suma-grupo (nombre lista-obj / col-grupos grupo)
(setq col-grupos (vla-get-Groups *aevl:dibujo*)
grupo (vl-catch-all-apply 'vla-Item (list col-grupos nombre)))
(cond ((vl-catch-all-error-p grupo)
(setq grupo (vla-Add col-grupos nombre))
(vla-AppendItems grupo (ax-lista->variant lista-obj))
grupo)
(t
(if (setq objetos (ax-no-grupo lista-obj grupo))
(vla-AppendItems grupo (ax-lista->variant objetos)))
grupo)))
;;;Listado 11.16. Función para añadir objetos a un Grupo.
(defun ax-si-grupo (lista-obj obj-grupo / tmp)
(vlax-for obj obj-grupo
(setq tmp (cons (vla-get-handle obj) tmp)))
(foreach obj lista-obj
(if (not (member (vla-get-handle obj) tmp))
(setq lista-obj (vl-remove obj lista-obj))))
lista-obj)
;;;Listado 11.17. Función que elimina de la lista los objetos que no forman parte del Grupo.
(defun ax-resta-grupo (nombre lista-obj / col-grupos grupo)
(setq col-grupos (vla-get-Groups *aevl:dibujo*)
grupo (vl-catch-all-apply 'vla-Item (list col-grupos nombre)))
(cond ((vl-catch-all-error-p grupo) nil)
(t
(if (setq objetos (ax-si-grupo lista-obj grupo))
(vla-RemoveItems grupo (ax-lista->variant objetos)))
(if (= (vla-get-Count grupo) 0)
(vla-Delete grupo)
grupo))))
;;;Listado 11.18. Función quita entidades de un Group.
