;;;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 12. Modificar entidades
(defun cmd-cambia-color (selección indice-color)
(vl-cmdf "._chprop" selección "" "_C" indice-color ""))
;;;Listado 12.1. Cambiar el color con CHPROP.
(defun circulo-en-extremo (radio / lineas i ent-linea pin pfi)
(if (setq lineas (ssget "X" '((0 . "LINE"))))
(progn (setq i 0)
(while (setq ent-linea (ssname lineas i))
(setq pin (valor-cod 10 ent-linea)
pfi (valor-cod 11 ent-linea))
(if (not (member pin dibujados))
(progn (vl-cmdf "._circle" pin radio)
(setq dibujados (cons pin dibujados))))
(if (not (member pfi dibujados))
(progn (vl-cmdf "._circle" pfi radio)
(setq dibujados (cons pfi dibujados))))
(setq i (1+ i))))))
;;;Listado 12.2. Función que dibuja círculos en los extremos de las líneas.
(defun recorte-linea-circulo (/ circulos lineas obj extremos)
(if (and (setq circulos (ssget "X" '((0 . "CIRCLE"))))
(setq lineas (ssget "X" '((0 . "LINE")))))
(progn (setq i 0)
(while (setq obj (ssname lineas i))
(setq extremos (cons
(valor-cod 11 obj)
(cons (valor-cod 10 obj) extremos))
i (1+ i)))
(foreach pt extremos
(vl-cmdf "._trim" circulos "" pt ""))
(if (> (getvar "cmdactive") 0)
(vl-cmdf)))))
;;;Listado 12.3. Función que demuestra el uso de RECORTA (_TRIM) desde una función VLISP.
(defun numera-nodos (lista-pts altura / i pt)
(setq
lista-pts
(vl-sort
lista-pts
'(lambda (pt1 pt2) (> (cadr pt1) (cadr pt2)))))
(setq i 0)
(while (setq pt (nth i lista-pts))
(ent-texto (itoa (1+ i))
(getvar "textstyle")
pt
pt
altura
1
2)
(setq i (1+ i))))
;;;Listado 12.4. Función que numera los nodos.
(defun C:GRAFO (/ *error* radio dibujados)
(defun *error* (msj)
(command-s "._UNDO" "_End")
(command-s "_U")
(cmd-salir)
(prompt msj))
(cmd-entrar)
(vl-cmdf "._UNDO" "_Begin")
(setq radio (valor-por-defecto
'getreal
"\nEspecifique radio del círculo "
10.0))
(circulo-en-extremo radio)
(recorte-linea-circulo)
(numera-nodos dibujados radio)
(vl-cmdf "._UNDO" "_End")
(cmd-salir)
(princ))
;;;Listado 12.5. Nuevo comando que automatiza la creación de diagramas de red.
(defun ent-mod-capa (lista-ent capa)
(entmod (subst (cons 8 capa) (assoc 8 lista-ent) lista-ent)))
;;;Listado 12.6. Función que cambia la Capa de una entidad.
(defun ent-desplaza-obj (lista-ent)
(if (apply 'or
(mapcar '(lambda (x) (= x (cdr (assoc 0 lista-ent))))
'("CIRCLE" "ELLIPSE" "ARC" "INSERT"
"POINT" "SHAPE" "TEXT" "MTEXT")))
(while (setq ctr (getpoint "\nDesplazar al punto: "))
(entmod (subst (cons 10 ctr) (assoc 10 lista-ent) lista-ent)))
(prompt "\nObjeto no admitido"))
(princ))
;;;Listado 12.7. Función que desplaza objetos usando ENTMOD.
(defun ent-a-layout (ename layout copia / le)
(setq le (entget ename))
(setq le (subst (cons 410 layout) (assoc 410 le) le))
(cond ((= (strcase layout) "MODEL")
(if (assoc 67 le)
(setq le (subst (cons 67 0) (assoc 67 le) le))))
(t
(if (assoc 67 le)
(setq le (subst (cons 67 1) (assoc 67 le) le))
(setq le (cons (cons 67 1) le)))))
(if copia
(entmake le)
(entmod le)))
;;;Listado 12.8. Función que desplaza o copia entre Presentaciones.
(defun 3d? (nombre-entidad)
(and (= (valor-cod 0 nombre-entidad) "POLYLINE")
(not (zerop (logand (valor-cod 70 nombre-entidad))))))
;;;Listado 12.9. Predicado que identifica una polilínea 3D.
(defun cierra-polilinea (nombre-entidad / lista)
(if (wcmatch (valor-cod 0 nombre-entidad) "*POLYLINE")
(progn
(setq lista (entget nombre-entidad))
(entmod
(subst
(cons 70 (logior (valor-cod 70 nombre-entidad) 1))
(assoc 70 lista)
lista)))))
;;;Listado 12.10. Función que cierra cualquier tipo de polilínea.
(defun abre-polilinea (nombre-entidad / lista)
(if (wcmatch (valor-cod 0 nombre-entidad) "*POLYLINE")
(progn
(setq lista (entget nombre-entidad))
(entmod
(subst
(cons 70 (logand (valor-cod 70 nombre-entidad) (+ 0 8 16 64)))
(assoc 70 lista)
lista)))))
;;;Listado 12.11. Función para abrir polilíneas usando LOGAND.
(defun abre-cierra-polilinea (nombre-entidad cerrado / lista)
(if (wcmatch (valor-cod 0 nombre-entidad) "*POLYLINE")
(progn
(setq lista (entget nombre-entidad))
(entmod
(subst (cons 70
(boole (if cerrado
7
1)
(valor-cod 70 nombre-entidad)
(if cerrado
1
(~ 1))))
(assoc 70 lista)
lista)))))
;;;Listado 12.12. Función para cerrar o abrir polilíneas usando BOOLE.
(defun prop-lwpol-vertices (lwpol / i x y z listapt)
(setq z (getpropertyvalue lwpol "Elevation")
i 0)
(while
(not (vl-catch-all-error-p
(setq x (vl-catch-all-apply
'getpropertyvalue
(list lwpol "Vertices" i "Position/X")))))
(setq y (getpropertyvalue
lwpol
"Vertices"
i
"Position/Y")
lst (cons (list x y z) listapt)
i (1+ i)))
(reverse lst))
;;;Listado 12.13. Lectura de los vértices de una LWPolyline usando getpropertyvalue.
(defun prop-spline-pts (spl / i n listapt)
(setq i 0)
(cond ((not (vl-catch-all-error-p
(setq n (vl-catch-all-apply
'getpropertyvalue
(list spl "NumFitPoints")))))
(repeat n
(setq listapt (cons (getpropertyvalue
spl
"FitPoints"
i
"Position")
listapt)
i (1+ i))))
(t
(setq n (getpropertyvalue spl "NumControlPoints"))
(repeat n
(setq listapt (cons (getpropertyvalue
spl
"ControlPoints"
i
"Position")
listapt)
i (1+ i)))))
(reverse listapt))
;;;Listado 12.14. Lectura de los puntos de Apoyo o de Control de una Spline usando getpropertyvalue.
(defun noncom-props (ent / props valor)
(setq
props (vl-remove-if
'null
(mapcar
'(lambda (prop)
(setq valor (vl-catch-all-apply
'getpropertyvalue
(list ent prop)))
(if (not (vl-catch-all-error-p valor))
(cons prop valor)))
'("LocalizedName" "3dPolylineClosed" "Angle" "Area"
"Associative" "BasePoint" "Center"
"Circumference" "Closed" "Color" "ConstantWidth"
"Degree" "Delta" "Diameter" "DrawOrder"
"EcsRotation" "Elevation" "EndAngle"
"EndFitTangent" "EndParam" "EndPoint"
"FitTolerance" "GradientAngle" "GradientCentered"
"GradientColor1" "GradientColor2" "GradientName"
"GradientOneColorMode" "GradientShift"
"GradientType" "HasFitData" "HasBulges"
"HasWidth" "HatchObjectType" "HatchStyle"
"IsHatch" "IsOnlyLines" "ISOPenWidth"
"IsOriginDisableForSVH" "IsPeriodic" "IsPlanar"
"IsSolidFill" "KnotParameterization" "Length"
"MajorAxis" "MajorRadius" "MinorAxis"
"MinorRadius" "Normal" "NumberOfHatchLines"
"NumberOfLoops" "NumberOfPatternDefinitions"
"NumControlPoints" "NumFitPoints" "Origin"
"Pattern" "PatternAngle" "PatternDouble"
"PatternFillType" "PatternName" "PatternScale"
"PatternSpace" "PatternType" "Plinegen"
"Poly3dType" "Position" "Radius" "RadiusRatio"
"SecondPoint" "ShadeTintValue" "SplineFrame"
"SplineIsPeriodic" "StartAngle" "StartFitTangent"
"StartParam" "StartPoint" "Thickness"
"TotalAngle" "Type" "UnitDir"))))
(cond ((= (cdr (assoc 0 (entget ent))) "LWPOLYLINE")
(setq
props (cons (cons "Vertices" (prop-lwpol-verts ent))
(reverse props))))
((= (cdr (assoc 0 (entget ent))) "SPLINE")
(setq props
(cons (cons (if (vl-catch-all-error-p
(vl-catch-all-apply
'getpropertyvalue
(list ent "NumFitPoints")))
"ControlPoints"
"FitPoints")
(prop-spline-pts ent))
(reverse props)))))
(reverse props))
;;;Listado 12.15. Lectura de las propiedades útiles para OBJETOS GRÁFICOS 2D.
(defun RGB->TrueColor (rgb)
(apply '+
(mapcar '(lambda (c i) (lsh c i))
rgb
'(16 8 0))))
;;;Listado 12.16. Función que convierte valores RGB a TrueColor.
(defun TrueColor->RGB (tcol)
(mapcar '(lambda (i) (lsh (lsh tcol i) -24))
'(8 16 24)))
;;;Listado 12.17. Función para extraer valores RGB de un TrueColor.
(defun ent-cambiacolor (entidad nuevocolor / listaent)
(setq listaent (entget entidad))
(setq listaent
(cond
((and (assoc 430 nuevocolor) (assoc 430 listaent))
(subst (assoc 430 nuevocolor) (assoc 430 listaent)
listaent))
((and (not (assoc 430 nuevocolor)) (assoc 430 listaent))
(vl-remove (assoc 430 listaent) listaent))
((assoc 430 nuevocolor)
(reverse (cons (assoc 430 nuevocolor) (reverse listaent))))
(t listaent)))
(setq listaent
(cond
((and (assoc 420 nuevocolor) (assoc 420 listaent))
(subst (assoc 420 nuevocolor) (assoc 420 listaent) listaent))
((and (not (assoc 420 nuevocolor)) (assoc 420 listaent))
(vl-remove (assoc 420 listaent) listaent))
((assoc 420 nuevocolor)
(reverse (cons (assoc 420 nuevocolor) (reverse listaent))))
(t listaent)))
(setq listaent
(if (assoc 62 listaent)
(subst (assoc 62 nuevocolor) (assoc 62 listaent) listaent)
(reverse (cons (assoc 62 nuevocolor) (reverse listaent)))))
(entmod listaent))
;;;Listado 12.18. Función que cambia el color de una entidad mediante entmod.
(defun C:ENTCOL (/)
(ent-cambiacolor
(car (entsel "\nDesigne una entidad para cambiar el color:"))
(acad_truecolordlg
(cons 420 (RGB->TrueColor (list 255 255 255)))
t)))
;;;Listado 12.19. Programa de prueba para ent-cambiacolor.
(defun rgb->cadena (rgb /)
(vl-string-translate
" "
","
(vl-string-trim "()" (vl-princ-to-string rgb))))
Listado 12.20. Conversión de la lista de colores RGB a cadena.
(defun prop-cambiacolor (entidad nuevocolor /)
(cond
((assoc 430 nuevocolor)
(setpropertyvalue
entidad
"Color"
(vl-string-translate "$" "," (cdr (assoc 430 nuevocolor)))))
((assoc 420 nuevocolor)
(setpropertyvalue
entidad
"Color"
(rgb->cadena
(TrueColor->RGB (cdr (assoc 420 nuevocolor))))))
(t
(setpropertyvalue
entidad
"Color"
(itoa (cdr (assoc 62 nuevocolor)))))))
;;;Listado 12.21. Función que cambia el color de una entidad usando setpropertyvalue.
(defun escala-colores
(rgb-ini rgb-fin numero / inc-rgb lista-color n)
(setq inc-rgb (mapcar '(lambda (i)
(/ (- (nth i rgb-ini) (nth i rgb-fin))
numero))
(list 0 1 2))
n 0)
(repeat (1- numero)
(setq lista-color (cons
(mapcar
'-
rgb-ini
(mapcar '(lambda (i) (* i n)) inc-rgb))
lista-color)
n (1+ n)))
(reverse (cons rgb-fin lista-color)))
;;;Listado 12.22. Función que calcula los valores RGB para una escala de color.
(defun datos-escala (/ ini fin pasos ops sel)
(prompt "\nDatos para Escala de colores.")
(while (or (not ini) (not fin) (not pasos))
(setq ops ""
ops (if (not ini)(strcat ops "Inicial ") ops)
ops (if (not fin)(strcat ops "Final ") ops)
ops (if (not pasos)(strcat ops "Pasos ") ops))
(if (not (setq msg (sustituye "/" " " ops)))(setq msg ops))
(apply 'initget (list 1 ops))
(setq sel (getkword (strcat "\nSeleccione opción [" msg "]: ")))
(cond
((= sel "Inicial")
(while (not (setq ini
(assoc 420 (acad_truecolordlg '(420 . 16391690) nil))))
(alert "Seleccione en \nla pestaña Truecolor.")))
((= sel "Final")
(while (not (setq fin
(assoc 420 (acad_truecolordlg '(420 . 410356) nil))))
(alert "Seleccione en \nla pestaña Truecolor.")))
((= sel "Pasos")
(initget (+ 1 2 4))
(setq pasos
(getint "\nNúmero de colores en la escala: ")))))
(list
(TrueColor->RGB (cdr ini))(TrueColor->RGB (cdr fin)) pasos))
;;;Listado 12.23. Entrada de datos para escala de colores.
(defun sel-somb (/ somb-sel ent lista-somb)
(setq somb-sel (ssget "X" '((0 . "HATCH")))
i 0)
(while (setq ent (ssname somb-sel i))
(setq lista-somb (cons ent lista-somb)
i (1+ i)))
lista-somb)
;;;Listado 12.24. Función para recuperar los objetos HATCH.
(defun aplica-color (lista-somb colores / ent area areas
sombreados i d-area indices indice)
(setq i 0)
(while (setq ent (nth i lista-somb))
(setq area (vl-catch-all-apply
'getpropertyvalue
(list ent "Area")))
(if (not (vl-catch-all-error-p area))
(setq areas (cons area areas)
sombreados (cons ent sombreados)))
(setq i (1+ i)))
(setq d-area
(/ (- (apply 'max areas) (apply 'min areas))
(length colores)))
(setq indices
(mapcar '(lambda (a) (read (rtos (/ a d-area) 2 0)))
areas)
i 0)
(while (setq ent (nth i sombreados))
(setq indice (nth i indices))
(cond ((< indice 0) (setq indice 0))
((>= indice (length colores))
(setq indice (1- (length colores)))))
(setpropertyvalue
ent
"Color"
(rgb->cadena (nth indice colores)))
(setq i (1+ i))))
;;;Listado 12.25. Función para aplicar una escala de color a los Sombreados.
(defun C:COLOR-AREA (/ datos escala colores sombreados)
(if (setq sombreados (sel-somb))
(progn (setq datos (datos-escala))
(setq escala (apply 'escala-colores datos))
(aplica-color sombreados escala))
(prompt "\nNo se encuentran sombreados"))
(princ))
;;;Listado 12.26. Función principal que aplica TrueColor a objetos HATCH.
(defun ax-link (obj nombre url descripcion ubicacion /
links link)
(vl-load-com)
(setq links (vla-get-Hyperlinks obj)
link (vla-Add links nombre))
(vla-put-URL link url)
(vla-put-URLDescription link descripcion)
(vla-put-URLNamedLocation link ubicacion))
;;;Listado 12.27 Función que añade un Hipervínculo a un objeto.
(defun ax-matriz-rectangular (ename num-fila num-col num-nivel
dist-fila dist-col dist-nivel)
(vla-ArrayRectangular
(vlax-ename->vla-object ename)
num-fila
num-col
num-nivel
dist-fila
dist-col
dist-nivel))
;;;Listado 12.28. Creación de una matriz rectangular 3D con ActiveX
