;;;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 10 Dibujar con Visual LISP
(defun cmd-circulo (centro radio /)
(cmd-entrar)
(command "._circle" centro radio)
(cmd-salir))
;;;Listado 10.1. Dibujo de un círculo utilizando COMMAND.
(defun cmdf-circulo (/ pt)
(cmd-entrar)
(vl-cmdf "._circle"
(setq pt (getpoint "\nIndique centro:"))
(getdist pt "\nEspecifique radio: "))
(cmd-salir))
;;;Listado 10.2. Dibujo de un círculo utilizando VL-CMDF.
(defun cmd-ttr (pt1 pt2 radio /)
(setvar "cmdecho" 0)
(vl-cmdf "._circle" "_ttr" pt1 pt2 radio)
(setvar "cmdecho" 1))
;;;Listado 10.3. Dibujo de un círculo a partir de dos puntos de tangencia y el radio.
(defun cmd-circulo (centro radio /)
(if (> (getvar "CMDACTIVE") 0)
(vl-cmdf))
(cmd-entrar)
(vl-cmdf "._circle" centro radio)
(cmd-salir)
(if (> (getvar "CMDACTIVE") 0)
(progn (vl-cmdf) nil)
t))
;;;Listado 10.4. Función CMD-CIRCULO con control de errores.
(defun cmd (cmd-nombre /)
(if (> (getvar "CMDACTIVE") 0)
(vl-cmdf))
(apply 'vl-cmdf (list cmd-nombre))
(while (> (getvar "CMDACTIVE") 0) (vl-cmdf pause)))
;;;Listado 10.5. Función universal para ejecutar comandos de manera interactiva.
(defun cmd-test ()
(alert "Pulse Aceptar para elegir un Color")
(initdia)
(cmd "._COLOR")
(alert "Pulse aceptar para dibujar un Círculo")
(cmd "._CIRCLE"))
;;;Listado 10.6. Función de que lanza comandos desde un programa AutoLISP.
(defun cmd-poly (lista-puntos 2d cerrado /)
(if (> (getvar "CMDACTIVE") 0)
(vl-cmdf))
(cmd-entrar)
(vl-cmdf
(if 2d
"._pline"
"._3dpoly"))
(foreach pt lista-puntos (vl-cmdf pt))
(vl-cmdf
(if cerrado
"_cl"
""))
(cmd-salir)
(if (> (getvar "CMDACTIVE") 0)
(progn (vl-cmdf) nil)
t))
;;;Listado 10.7. Función para dibujar una polilínea 2D o 3D.
(defun ent-pt (xyz)
(entmake (list '(0 . "POINT") (cons 10 xyz))))
;;;Listado 10.8. Función para dibujo de un punto.
(defun valor-cod (clave ename)
(cdr (assoc clave (entget ename))))
;;;Listado 10.9. Extracción del valor asociado a un código DXF.
(defun ent-copia (lista-ent / ctr)
(if
(apply 'or
(mapcar '(lambda (x) (= x (cdr (assoc 0 lista-ent))))
'("CIRCLE" "ELLIPSE" "ARC" "INSERT" "POINT" "SHAPE" "TEXT" "MTEXT")))
(while (setq ctr (getpoint "\nNueva ubicación: "))
(entmake
(subst (cons 10 ctr) (assoc 10 lista-ent) lista-ent)))
(prompt "\nObjeto no admitido"))
(princ))
;;;Listado 10.10. Función que utiliza ENTMAKE para copiar objetos.
(defun ent-circ (centro radio capa normal-vec)
(entmake
(list '(0 . "CIRCLE")
'(100 . "AcDbEntity")
'(100 . "AcDbCircle")
(cons 8 capa)
(cons 10 centro)
(cons 40 radio)
(cons 210 normal-vec))))
;;;Listado 10.11. Función que dibuja círculos en diferentes capas y planos.
(defun ent-texto (txt-cadena estilo pt1 pt2 txt-altura h-just v-just)
(entmake
(list '(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 1 txt-cadena)
(cons 7 estilo)
(cons 10 pt1)
(cons 11 pt2)
(cons 40 txt-altura)
(cons 72 h-just)
(cons 73 v-just))))
;;;Listado 10.12. Función que crea una entidad de texto en una línea.
(defun ent-dib-texto (pt-ins altura numeracion)
(ent-text
numeracion
(getvar "TEXTSTYLE")
pt-ins
pt-ins
altura
1
2))
;;;Listado 10.13. Reemplazo para la función dib-texto utilizando ENTMAKE.
(defun just-txt-ops (token /)
(list
(cond
((or (wcmatch (strcase just) "@L") (wcmatch token "L*"))
(cons 72 0))
((or (wcmatch (strcase just) "@C") (wcmatch token "C*"))
(cons 72 1))
((or (wcmatch (strcase just) "@R") (wcmatch token "R*"))
(cons 72 2))
((wcmatch (strcase token) "A*") (cons 72 3))
((wcmatch (strcase token) "M*") (cons 72 4))
((wcmatch (strcase token) "F*") (cons 72 5)))
(cond
((wcmatch (strcase token) "T@") (cons 73 3))
((wcmatch (strcase token) "M@") (cons 73 2))
((wcmatch (strcase token) "B@") (cons 73 1))
(t (cons 73 0)))))
;;;Listado 10.14. Elección de los valores de código de grupo según los símbolos de las opciones de justificación.
(defun ent-just-txt (txt-cadena style pt1 pt2 txt-altura just ang /)
(entmake
(append
(list '(0 . "TEXT")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 1 txt-cadena)
(cons 7 style)
(cons 10 pt1)
(cons 11 pt2)
(cons 40 txt-altura)
(cons 50 ang))
(just-txt-ops just))))
;;;Listado 10.15. Función que crea texto justificado usando los símbolos de las opciones.
(defun C:ENT-TXT (/ just pt1 pt2 altura cadena-txt)
(prompt "\Justificación del texto: ")
(initget
1
"Left Align Fit Center Middle Right TL TC TR ML MC MR BL BC BR")
(setq just (getkword
"[Left/Align/Fit/Center/Middle/Right/TL/TC/TR/ML/MC/MR/BL/BC/BR]:"))
(cond
((or (= just "Align") (= just "Fit"))
(initget 1)
(setq pt1 (getpoint
"\nPrimer punto de la línea base del texto: "))
(initget 1)
(setq pt2 (getpoint
pt1
"\nSegundo punto de la línea base del texto: ")))
(t
(initget 1)
(setq pt1 (getpoint
"\nIndique el punto de inserción del texto: ")
pt2 pt1)))
(initget 1)
(setq altura (getdist
pt1
"Altura del texto: "))
(initget 1)
(setq cadena-txt (getstring
"\nTexto a insertar: "))
(ent-just-txt
cadena-txt
(getvar "TEXTSTYLE")
pt1
pt2
altura
just
0)
(princ))
;;;Listado 10.16. Programa de ejemplo usando ENT-JUST-TXT.
(defun valores (clave lista / sublista resultado)
(while (setq sublista (assoc clave lista))
(setq resultado (cons (cdr sublista) resultado)
lista (cdr (member sublista lista))))
(reverse resultado))
;;;Listado 10.17 Extracción de valores múltiples contenidos en una lista de asociación.
(defun vert-poly (lista / coord-z)
(setq coord-z (cdr (assoc 38 lista)))
(mapcar '(lambda (2d) (reverse (cons coord-z (reverse 2d))))
(valores 10 lista)))
;;;Listado 10.18. Función que devuelve los vértices de una LWPOLYLINE.
(defun ent-poly (vertices cerrado)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 38
(if (> (length (car vertices)) 2)
(nth 2 (car vertices))
(getvar "elevation")))
(cons 90 (length vertices))
(cons 70
(if cerrado
1
0)))
(mapcar '(lambda (x) (cons 10 x)) vertices))))
;;;Listado 10.19. Creación de Polilíneas usando ENTMAKE.
(defun ent-poly-2 (vertices cerrado capa normal-vec)
(entmake
(append
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 8 capa)
(cons 38
(if (> (length (car vertices)) 2)
(nth 2 (car vertices))
(getvar "elevation")))
(cons 90 (length vertices))
(cons 70
(if cerrado
1
0))
(cons 210 normal-vec))
(mapcar '(lambda (x) (cons 10 x)) vertices))))
;;;Listado 10.20. Creación de una Polilínea especificando la capa y el sistema de coordenadas.
(defun ent-cabecera (capa cerrado)
(entmake
(list '(0 . "POLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDb3dPolyline")
(cons 8 capa)
'(10 0.0 0.0 0.0)
(cons 70
(+ 8
(if cerrado
1
0))))))
;;;Listado 10.21. Función que crea la cabecera de la Polilínea 3D.
(defun ent-vertice (xyz capa)
(entmake
(list '(0 . "VERTEX")
'(100 . "AcDbEntity")
'(100 . "AcDbVertex")
'(100 . "AcDb3dPolylineVertex")
(cons 8 capa)
(cons 10 xyz)
'(70 . 32)
'(50 . 0))))
;;;Listado 10.22. Función que crea una entidad VERTEX.
(defun ent-seqend (capa)
(entmake
(list '(0 . "SEQEND") '(100 . "AcDbEntity") (cons 8 capa))))
;;;Listado 10.23. Función que crea una entidad SEQEND.
(defun ent-3dpol (vertices capa cerrado)
(ent-cabecera capa cerrado)
(foreach xyz vertices (ent-vertice xyz capa))
(ent-seqend capa))
;;;Listado 10.24. Función que crea una Polilínea 3D usando ENTMAKE.
(defun enames-bloque (id-ent / tmp)
(while id-ent
(setq tmp (cons (cdr (assoc -1 (entget id-ent))) tmp)
id-ent (entnext id-ent)))
(reverse tmp))
;;;Listado 10.25. Obtención de los componentes de un Bloque.
(defun ent-attdef (id msj valor pt-ins altura visible)
(entmake
(list '(0 . "ATTDEF")
'(8 . "0")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 pt-ins)
(cons 40 altura)
(cons 1 valor)
'(100 . "AcDbAttributeDefinition")
(cons 3 msj)
(cons 2 id)
(cons 70
(if visible
0
1)))))
;;;Listado 10.26. Entidad ATTDEF creada con ENTMAKE.
(defun ent-bloque (nombre pt-ins atrib-var)
(entmake
(list '(0 . "BLOCK")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockBegin")
'(8 . "0")
(cons 2 nombre)
(cons 10 pt-ins)
(cons 70
(if atrib-var
2
0)))))
;;;Listado 10.27. Creación de la cabecera del Bloque.
(defun ent-endblk ()
(entmake
(list '(0 . "ENDBLK")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockEnd")
'(8 . "0"))))
;;;Listado 10.28. Creación de la entidad fin-de-secuencia del Bloque.
(defun ent-torre-block ()
(ent-bloque "TORRE" '(0.0 0.0 0.0) t)
(ent-poly-2
'((-0.5 -0.5 0.0)
(0.5 -0.5 0.0)
(0.5 0.5 0.0)
(-0.5 0.5 0.0))
t
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((-0.5 -0.5 0.0) (0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((0.5 -0.5 0.0) (-0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-attdef
"ID-TORRE"
"Número de Torre"
"00"
'(0.75 -0.5 0.0)
0.5
nil)
(ent-endblk))
;;;Listado 10.29 Función para la creación de un Bloque.
(defun ed-torre-block ()
(vl-cmdf "_BEDIT" "TORRE")
(ent-poly-2
'((-0.5 -0.5 0.0)
(0.5 -0.5 0.0)
(0.5 0.5 0.0)
(-0.5 0.5 0.0))
t
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((-0.5 -0.5 0.0) (0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-poly-2
'((0.5 -0.5 0.0) (-0.5 0.5 0.0))
nil
"0"
'(0.0 0.0 1.0))
(ent-attdef
"ID-TORRE"
"Número de Torre"
"00"
'(0.75 -0.5 0.0)
0.5
nil)
(vl-cmdf "_BCLOSE" "_Save"))
;;;Listado 10.30. Creación del bloque TORRE usando el Editor de Bloques.
(defun espacio-actual (dibujo /)
(vla-get-block (vla-get-ActiveLayout dibujo)))
;;;Listado 10.31. Función que devuelve el espacio actual.
(defun 3d->2d (pt) (list (car pt) (cadr pt)))
;;;Listado 10.32. Función auxiliar 3d->2d.
(defun ax-poly (vertices cerrado / obj)
(setq obj (vla-AddLightWeightPolyline
(espacio-actual *aevl:dibujo*)
(vlax-make-variant
(ax-lista->matriz
(apply 'append (mapcar '3d->2d vertices))))))
(if cerrado
(vlax-put-property obj 'Closed :vlax-true))
(if (nth 2 (car vertices))
(vlax-put-property obj 'Elevation (nth 2 (car vertices))))
obj)
;;;Listado 10.33. Creación de una LWPOLYLINE usando ActiveX.
(defun ax-3dpol (vertices cerrado / obj)
(setq obj (vla-Add3DPoly
(espacio-actual *aevl:dibujo*)
(vlax-make-variant
(ax-lista->matriz (apply 'append vertices)))))
(if cerrado
(vlax-put-property obj 'closed :vlax-true))
obj)
;;;Listado 10.34. 3D polyline con métodos ActiveX.
(defun ax-col-bloques (/)
(if (null *aevl:bloques*)
(progn (setq *aevl:bloques* (vla-get-blocks *aevl:dibujo*))
(pragma '((protect-assign *aevl:bloques*)))
*aevl:bloques*)
*aevl:bloques*))
;;;Listado 10.35. Referenciar la colección BLOCKS.
(defun ax-punto-cota (/ tmp atrib)
(setq tmp (vla-add (ax-col-bloques)
(vlax-3d-point '(0.0 0.0 0.0))
"PUNTO-COTA"))
(vla-addline
tmp
(vlax-3d-point '(-0.5 0.0 0.0))
(vlax-3d-point '(0.5 0.0 0.0)))
(vla-addline
tmp
(vlax-3d-point '(0.0 -0.5 0.0))
(vlax-3d-point '(0.0 0.5 0.0)))
(setq atrib (vla-addattribute
tmp
0.5
0
"Point elevation"
(vlax-3d-point '(0.0 -1.0 0.0))
"ELEV"
"0.0"))
(vlax-put-property atrib "Alignment" acAlignmentTopCenter)
(vlax-put-property
atrib
"TextAlignmentPoint"
(vlax-3d-point '(0.0 -1.0 0.0)))
tmp)
;;;Listado 10.36. Creación de un bloque usando métodos ActiveX.
(defun cmd-capa (nombre color tipolin)
(vl-cmdf "._layer" "_m" nombre "_c" color nombre "_l" tipolin nombre ""))
;;;Listado 10.37. Función que crea una Capa usando el comando CAPA (_LAYER).
(defun cmd-cargatipolin (nombre)
(if (not (tblsearch "LTYPE" nombre))
(vl-cmdf "._linetype"
"_l"
nombre
(if (= (getvar "measurement") 1)
(findfile "acadiso.lin")
(findfile "acad.lin"))
"")))
;;;Listado 10.38. Cargar un Tipo de Línea.
(defun locale-ltyp (nombre / lang ltyps)
(setq lang (vl-position
(getvar "UILocale")
'("en-US" "de-DE" "es-ES" "fr-FR" "it-IT" "pt-BR"))
ltyps '(("BORDER" "RAND" "MORSE_G" "BORDURE" "BORDO" "BORDA")
("BORDER2" "RAND2" "MORSE_G2" "BORDURE2" "BORDO2" "BORDA2")
("BORDERX2" "RANDX2" "MORSE_Gx2" "BORDUREX2" "BORDOX2" "BORDAX2")
("CENTER" "MITTE" "CENTRO" "AXES" "CENTRO" "CENTRO")
("CENTER2" "MITTE2" "CENTRO2" "AXES2" "CENTRO2" "CENTRO2")
("CENTERX2" "MITTEX2" "CENTROx2" "AXESX2" "CENTROX2" "CENTROX2")
("DASHDOT" "STRICHPUNKT" "TRAZO_Y_PUNTO" "TIRETPT" "TRATTOPUNTO"
"TRAÇOPONTO")
("DASHDOT2" "STRICHPUNKT2" "TRAZO_Y_PUNTO2" "TIRETPT2" "TRATTOPUNTO2"
"TRAÇOPONTO2")
("DASHDOTX2" "STRICHPUNKTX2" "TRAZO_Y_PUNTOX2" "TIRETPTX2"
"TRATTOPUNTOX2" "TRAÇOPONTOX2")
("DASHED" "STRICHLINIE" "TRAZOS" "INTERROMPU" "TRATTEGGIATA"
"TRACEJADA")
("DASHED2" "STRICHLINIE2" "TRAZOS2" "INTERROMPU2" "TRATTEGGIATA2"
"TRACEJADA2")
("DASHEDX2" "STRICHLINIEX2" "TRAZOSX2" "INTERROMPUX2"
"TRATTEGGIATAX2" "TRACEJADAX2")
("DIVIDE" "GETRENNT" "MORSE_D" "DIVISE" "DIVIDI" "DIVISA")
("DIVIDE2" "GETRENNT2" "MORSE_D2" "DIVISE2" "DIVIDI2" "DIVISA2")
("DIVIDEX2" "GETRENNTX2" "MORSE_DX2" "DIVISEX2" "DIVIDIX2" "DIVISAX2")
("DOT" "PUNKT" "PUNTOS" "POINTILLE" "PUNTO" "PONTO")
("DOT2" "PUNKT2" "PUNTOS2" "POINTILLE2" "PUNTO2" "PONTO2")
("DOTX2" "PUNKTX2" "PUNTOSX2" "POINTILLEX2" "PUNTOX2" "PONTOX2")
("HIDDEN" "VERDECKT" "LÍNEAS_OCULTAS" "CACHE" "NASCOSTA" "OCULTA")
("HIDDEN2" "VERDECKT2" "LÍNEAS_OCULTAS2" "CACHE2" "NASCOSTA2"
"OCULTA2")
("HIDDENX2" "VERDECKTX2" "LÍNEAS_OCULTASX2" "CACHEX2" "NASCOSTAX2"
"OCULTAX2")
("PHANTOM" "PHANTOM" "VALS" "FANTOME" "FANTASMA" "FANTASMA")
("PHANTOM2" "PHANTOM2" "VALS2" "FANTOME2" "FANTASMA2" "FANTASMA2")
("PHANTOMX2" "PHANTOMX2" "VALSX2" "FANTOMEX2" "FANTASMAX2"
"FANTASMAX2")
("FENCELINE1" "GRENZE1" "LÍMITE1" "LIMITE1" "LIMITE1" "CERCA1")
("FENCELINE2" "GRENZE2" "LÍMITE2" "LIMITE2" "LIMITE2" "CERCA2")
("TRACKS" "EISENBAHN" "VÍAS" "RAILS" "BINARIO" "TRILHAS")
("BATTING" "ISOLATION" "AISLAMIENTO" "ISOLATION" "ISOLAMENTO"
"ISOLAMENTO")
("HOT_WATER_SUPPLY" "HEISSWASSERLEITUNG" "AGUA_CALIENTE" "EAU_CHAUDE"
"ALIMENTAZIONE_ACQUA_CALDA" "LINHA_DE_ÁGUA_QUENTE")
("GAS_LINE" "GASLEITUNG" "GAS" "GAZ" "GASDOTTO" "LINHA_DE_GÁS")
("ZIGZAG" "ZICKZACK" "ZIGZAG" "ZIGZAG" "ZIGZAG" "ZIGUEZAGUE")))
(cond
((setq ltyp (assoc (strcase nombre) ltyps)) (nth lang ltyp))
(t nombre)))
;;;Listado 10.39. Función para la traducción de nombres de Tipos de Línea.
(defun usar? (capa)
(zerop
(logand (cdr (assoc 70 (tblsearch "LAYER" capa))) (+ 1 4))))
;;;Listado 10.40. Comprobación de si una Capa no está Desactivada, Inutilizada o Bloqueada.
(defun ent-capa (nombre color tipolin)
(entmake
(list '(0 . "LAYER")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLayerTableRecord")
(cons 2 nombre)
'(70 . 0)
(cons 62 color)
(cons 6 tipolin)
'(290 . 1)
'(370 . -3))))
;;;Listado 10.41. Creación de una Capa utilizando ENTMAKE.
(defun ent-tipolin (nombre descripcion lista-param)
(entmake
(append
(list '(0 . "LTYPE")
'(100 . "AcDbSymbolTableRecord")
'(100 . "AcDbLinetypeTableRecord")
(cons 2 nombre)
'(70 . 0)
(cons 3 descripcion)
(cons 72 (ascii (nth 0 lista-param)))
(cons 73 (- (length lista-param) 1))
(cons 40 (apply '+ (mapcar 'abs (cdr lista-param)))))
(apply 'append
(mapcar '(lambda (x) (list (cons 49 x) '(74 . 0)))
(cdr lista-param))))))
;;;Listado 10.42. Función que crea un Tipo de Línea utilizando ENTMAKE.
(defun ax-capa (col-capa nombre color tipolin / capa)
(setq capa (vla-add col-capa nombre))
(vla-put-Color capa color)
(vla-put-Linetype capa tipolin)
capa)
;;;Listado 10.43. Creación de una Capa con ActiveX.
(defun ax-cargatipolin (nombre / tmp)
(setq nombre (locale-ltyp nombre))
(if
(not
(ax-existe?
nombre
(setq tmp (vla-get-Linetypes *aevl:dibujo*))))
(progn
(vla-load tmp
nombre
(if (= (getvar "measurement") 1)
(findfile "acadiso.lin")
(findfile "acad.lin")))
(vla-put-ActiveLinetype *aevl:dibujo* (vla-item tmp nombre)))
(vla-put-ActiveLinetype *aevl:dibujo* (vla-item tmp nombre))))
;;;Listado 10.44. Cargar un Tipo de Línea utilizando ActiveX.
(defun ax-define-carga-tipolin (nombre descripcion definicion / arch arch-id)
(setq arch (vl-filename-mktemp nil nil ".lin")
arch-id (open arch "w"))
(write-line (strcat "*" nombre "," descripcion) arch-id)
(write-line definicion arch-id)
(close arch-id)
(vla-load (vla-get-linetypes *aevl:dibujo*) nombre arch)
(vl-file-delete arch))
;;;Listado 10.45. Definir y cargar un Tipo de Línea con ActiveX.
