;;;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 19
(defun datos-malla-poliedro (/)
(initget 1 "Tetraedro Hexaedro Dodecaedro")
(setq clase (getkword
"\nTipo: [Tetraedro/Hexaedro/Dodecaedro]: "))
(initget 1)
(setq centro (getpoint "\nCentro del poliedro: "))
(initget (+ 1 2 4))
(setq radio (getdist centro "\Radio de la esfera circunscrita: "))
(initget (+ 1 4))
(while
(> (setq nivel (getint "\nNivel de suavizado:"))
(getvar "SMOOTHMESHMAXLEV"))
(prompt
(strcat
"\nEl nivel de suavizado no debe ser mayor que "
(itoa (getvar "SMOOTHMESHMAXLEV"))))
(initget (+ 1 2 4)))
(initget 1 "Siempre Nunca 1 2 3")
(setq pliegue (getkword
"\nNivel pliegue de aristas [Siempre/Nunca/1/2/3]: "))
(cond
((= pliegue "Siempre") (setq pliegue -1))
((= pliegue "Nunca") (setq pliegue 0))
(t (setq pliegue (atof pliegue)))))
;;;Listado 19.1. Entrada de datos para la Malla Poliédrica.
(defun aristas-cara (caras / i v0 v1 v2 indices-arista)
(foreach cara caras
(setq i 0
v0 (nth i cara))
(repeat (1- (length cara))
(setq v1 (nth i cara)
i (1+ i)
v2 (nth i cara))
(if
(not
(or (member (list v1 v2) indices-arista)
(member (list v2 v1) indices-arista)))
(setq indices-arista (cons (list v1 v2) indices-arista))))
(if
(not
(or (member (list v2 v0) indices-arista)
(member (list v0 v2) indices-arista)))
(setq indices-arista (cons (list v2 v0) indices-arista))))
(apply 'append (reverse indices-arista)))
;;;Listado 19.2. Función que crea la lista de aristas de la Malla.
(defun ent-mesh (vertices caras aristas nivel pliegue / res lista-ent)
(setq res (cons (cons 91 nivel) res)
res (cons (cons 92 (length vertices)) res))
(foreach vertex vertices
(setq res (cons (cons 10 vertex) res)))
(setq res (cons
(cons
93
(+ (length caras)
(length (apply 'append caras))))
res))
(foreach cara caras
(setq res (cons (cons 90 (length cara)) res))
(foreach dato cara
(setq res (cons (cons 90 dato) res))))
(setq res (cons (cons 94 (/ (length aristas) 2)) res))
(foreach ptfinal aristas (setq res (cons (cons 90 ptfinal) res)))
(setq res (cons (cons 95 (/ (length aristas) 2)) res))
(repeat (/ (length aristas) 2)
(setq res (cons (cons 140 pliegue) res)))
(setq lista-ent (append
(list
'(0 . "MESH")
'(100 . "AcDbEntity")
'(100 . "AcDbSubDMesh")
'(71 . 2)
'(72 . 0))
(reverse res)))
(if (entmake lista-ent)
(entlast)))
;;;Listado 19.3. Creación de una entidad MESH mediante ENTMAKE.
(defun C:POLIEDRO-MALLA (/ mtrans clase centro radio
nivel vertices caras aristas pliegue obj)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-malla-poliedro)
(op-poliedro clase)
(setq caras (mapcar '(lambda (cara) (mapcar '1- cara)) caras)
aristas (aristas-cara caras)
obj (ent-mesh vertices caras aristas nivel pliegue))
(if obj
(progn
(setq obj (vlax-ename->vla-object obj))
(ax-escala obj (list radio radio radio))
(if mtrans (vla-TransformBy obj mtrans))
(ax-traslacion obj (trans centro 1 0 t))
(ax-SOsup)))
(vla-EndUndoMark *aevl:dibujo*)
(princ))
;;;Listado 19.4. Función principal C:POLIEDRO-MALLA.
(defun datos-malla-subd (/ nombre cad n-caras)
(initget 1)
(setq nombre (getstring "\nFunción a emplear para la malla: "))
(while (not (setq ecuacion (car (atoms-family 0 (list nombre)))))
(prompt
(strcat "\nLa función "
nombre
" no se ha definido en el contexto actual."))
(initget 1)
(setq nombre (getstring "\nIndique función a emplear: ")))
(initget 1)
(setq centro (getpoint "\nCentro de la malla: "))
(initget (+ 1 2 4))
(setq dim-x (getdist centro "\nDimensión en X de la malla: "))
(initget (+ 1 2 4))
(setq dim-y (getdist centro "\nDimensión en Y de la malla: "))
(initget (+ 1 2 4))
(setq dim-z (getdist centro "\nDimensión en Z de la malla: "))
(if (< dim-x dim-y)
(setq cad "X")
(setq cad "Y"))
(initget (+ 1 2 4))
(setq n-caras (getint
(strcat "\nCantidad de caras en la dimensión "
cad
": ")))
(if (> dim-x dim-y)
(setq filas n-caras
columnas (fix (/ dim-x (/ dim-y n-caras))))
(setq filas (fix (/ dim-y (/ dim-x n-caras)))
columnas n-caras)))
;;;Listado 19.5. Función que solicita los datos para una Malla de Subdivisión.
(defun calc-vertices-malla (dim-x dim-y ecuacion dim-z filas columnas / xmin ymin dx
dy cara caras x0 y0)
(setq xmin (- (/ dim-x 2))
ymin (- (/ dim-y 2))
dx (/ dim-x columnas)
dy (/ dim-y filas))
(setq x0 xmin
y0 ymin)
(repeat columnas
(setq y0 ymin)
(repeat filas
(setq cara (list (list xmin y0)
(list (+ xmin dx) y0)
(list (+ xmin dx) (+ y0 dy))
(list xmin (+ y0 dy))))
(setq caras (cons cara caras)
y0 (+ y0 dy)))
(setq xmin (+ xmin dx)))
(coord-z (reverse caras) ecuacion dim-z))
;;;Listado 19.6. Función que calcula las coordenadas de los vértices para cada cara.
(defun coord-z (caras ecuacion dim-z / lst-z altura f-esc)
(setq lst-z (mapcar
'(lambda (cara)
(mapcar '(lambda (pt) (apply ecuacion pt))
cara))
caras)
altura (- (apply 'max (apply 'append lst-z))
(apply 'min (apply 'append lst-z)))
f-esc (/ dim-z altura)
lst-z (mapcar
'(lambda (lst-cara)
(mapcar '(lambda (z) (* z f-esc)) lst-cara))
lst-z))
(mapcar
'(lambda (cara elev)
(mapcar '(lambda (pt z) (append pt (list z)))
cara
elev))
caras
lst-z))
;;;Listado 19.7. Función que calcula los valores de la coordenada Z.
(defun lista-vertices-unicos (caras / lista-puntos)
(foreach cara caras
(foreach vertice cara
(if (not (member vertice lista-puntos))
(setq lista-puntos (cons vertice lista-puntos)))))
(reverse lista-puntos))
;;;Listado 19.8. Función que genera la lista de vértices sin duplicados.
(defun lista-indices-caras (caras vertices-unicos / indices indices-cara)
(foreach cara caras
(foreach vertice cara
(setq indices (cons (vl-position vertice vertices-unicos)
indices)))
(setq indices-cara (cons indices indices-cara)
indices nil))
(reverse indices-cara))
;;;Listado 19.9. Función que crea la lista de índices de caras.
(defun subd-malla-rectangular (coords-vertices-cara / vertices caras aristas obj)
(setq vertices (lista-vertices-unicos coords-vertices-cara)
caras (lista-indices-caras coords-vertices-cara vertices)
aristas (aristas-cara caras)
obj (ent-mesh vertices caras aristas 0 -1)))
;;;Listado 19.10. Función que genera la estructura de datos y crea la malla.
(defun C:MALLA-SUBD (/ mtrans ecuacion centro dim-x dim-y dim-z filas columnas
n-caras coord-vertices obj)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-malla-subd)
(setq coord-vertices (calc-vertices-malla dim-x dim-y ecuacion dim-z filas columnas)
obj (subd-malla-rectangular coord-vertices))
(cond
(obj
(setq obj (vlax-ename->vla-object obj))
(if mtrans
(vla-TransformBy obj mtrans))
(ax-traslacion obj (trans centro 1 0 t))
(ax-SOsup))
(t (prompt "\nError en la construcción de la malla.")))
(vla-EndUndoMark *aevl:dibujo*)
(princ))
;;;Listado 19.11. Función principal C:MALLA-SUBD.
(defun cmd-mesh-caja (centro n-div dim-x dim-y dim-z esquina / dims d-inc divs
pt-esquina obj)
(setq dims (list dim-x dim-y dim-z)
d-inc (/ (apply 'max (list dim-x dim-y dim-z)) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims)
divs (mapcar
'(lambda (div)
(if (< div 1)
1
div))
divs))
(setvar "DIVMESHBOXLENGTH" (nth 0 divs))
(setvar "DIVMESHBOXWIDTH" (nth 1 divs))
(setvar "DIVMESHBOXHEIGHT" (nth 2 divs))
(if esquina
(setq pt-esquina (mapcar '+ centro (list dim-x dim-y 0))
obj (vl-cmdf "._MESH" "_B" centro pt-esquina dim-z))
(setq obj (vl-cmdf "._MESH" "_B" "_C" centro "_L" dim-x dim-y dim-z)))
(if obj
(entlast)))
;;;Listado 19.12. Malla en forma de prisma rectangular.
(defun long-elipse (dim-x dim-y /)
(*
pi
(+ dim-x dim-y)
(+ 1
(/
(* 3.0 (expt (/ (- dim-x dim-y) (+ dim-x dim-y)) 2))
(+ 10.0
(sqrt
(- 4.0
(* 3.0
(expt (/ (- dim-x dim-y) (+ dim-x dim-y))
2.0)))))))))
;;;Listado 19.13. Función que calcula la circunferencia de una elipse.
(defun cmd-mesh-cono (centro n-div dim-x dim-y dim-z / r-max dims d-inc divs obj)
(setq r-max (apply 'max (list dim-x dim-y))
dims (list (long-elipse dim-x dim-y) r-max dim-z)
d-inc (/ (apply 'max dims) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims)
divs (mapcar
'(lambda (div)
(if (< div 1)
1
div))
divs))
(setvar "DIVMESHCONEAXIS" (nth 0 divs))
(setvar "DIVMESHCONEBASE" (nth 1 divs))
(setvar "DIVMESHCONEHEIGHT" (nth 2 divs))
(setq obj
(vl-cmdf "_MESH"
"_Cone"
"_Elliptical"
"_C"
centro
dim-x
(list (nth 0 centro)
(+ (nth 1 centro) dim-y)
(nth 2 centro))
dim-z))
(if obj
(entlast)))
;;;Listado 19.14. Función que crea una Malla en forma de cono.
(defun cmd-mesh-cilindro (centro n-div dim-x dim-y dim-z / r-max dims d-inc divs obj)
(setq r-max (apply 'max (list dim-x dim-y))
dims (list (long-elipse dim-x dim-y) r-max dim-z)
d-inc (/ (apply 'max dims) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims)
divs (mapcar
'(lambda (div)
(if (< div 1)
1
div))
divs))
(setvar "DIVMESHCYLAXIS" (nth 0 divs))
(setvar "DIVMESHCYLBASE" (nth 1 divs))
(setvar "DIVMESHCYLHEIGHT" (nth 2 divs))
(setq obj (vl-cmdf "._MESH"
"_CY"
"_E"
"_C"
centro
dim-x
(list (nth 0 centro)
(+ (nth 1 centro) dim-y)
(nth 2 centro))
(list (nth 0 centro)
(nth 1 centro)
(+ (nth 2 centro) dim-z))))
(if obj
(entlast)))
;;;Listado 19.15. Función que crea una Malla en forma de Cilindro.
(defun cmd-mesh-esfera (centro n-div radio / dims d-inc divs obj)
(setq dims (list (* 2 pi radio) (* pi radio))
d-inc (/ (car dims) n-div)
divs (mapcar '(lambda (dim) (fix (/ dim d-inc))) dims))
(if (> (nth 0 divs) 2)
(setvar "DIVMESHSPHEREAXIS" (nth 0 divs))
(setvar "DIVMESHSPHEREAXIS" 3))
(if (> (nth 1 divs) 1)
(setvar "DIVMESHSPHEREHEIGHT" (nth 1 divs))
(setvar "DIVMESHSPHEREHEIGHT" 2))
(setq obj (vl-cmdf "._MESH" "_S" centro radio))
(if obj
(entlast)))
;;;Listado 19.16. Función que crea una Malla en forma de Esfera.
(defun entmod-mesh (ename ecuacion dim-z / ent-list vertices lst-z altura f-esc x y z
vertices-mod nueva-lista)
(if (eq (type ename) 'VLA-OBJECT)
(setq ename (vlax-vla-object->ename ename)))
(setq ent-list (entget ename)
vertices (valores 10 ent-list)
lst-z (mapcar
'(lambda (vert)
(apply ecuacion
(list (nth 0 vert) (nth 1 vert))))
vertices)
altura (- (apply 'max lst-z) (apply 'min lst-z))
f-esc (/ dim-z altura))
(foreach vertex vertices
(setq x (nth 0 vertex)
y (nth 1 vertex)
z (+ (nth 2 vertex)
(* f-esc (apply ecuacion (list x y))))
vertices-mod (cons (list x y z) vertices-mod)))
(setq vertices-mod (reverse vertices-mod))
(setq i 0
nueva-lista ent-list)
(while (< i (length vertices))
(setq nueva-lista (subst (cons 10 (nth i vertices-mod))
(cons 10 (nth i vertices))
nueva-lista)
i (1+ i)))
(entmod nueva-lista)
(entupd ename))
;;;Listado 19.17. Modificación de una entidad MESH mediante ENTMOD.
(defun ax-mod-mesh (obj ecuacion dim-z / nivel xyz lst-z i pt)
(if (eq (type obj) 'ENAME)
(setq ename (vlax-ename->vla-object obj)))
(setq nivel (vla-get-Smoothness obj))
(if (> nivel 0)
(vla-put-Smoothness obj 0))
(setq xyz (vlax-safearray->list
(vlax-variant-value (vla-get-Coordinates obj)))
lst-z (cal-z xyz ecuacion dim-z)
i 0)
(repeat (vla-get-VertexCount obj)
(setq pt (vlax-safearray->list
(vlax-variant-value (vla-get-Coordinate obj i))))
(vla-put-Coordinate
obj
i
(vlax-3d-point
(list (nth 0 pt)
(nth 1 pt)
(+ (nth 2 pt) (nth i lst-z)))))
(setq i (1+ i)))
(if (> nivel 0)
(vla-put-Smoothness obj nivel)))
;;;Listado 19.18. Modificación de una entidad MESH mediante ActiveX.
(defun par-rev (x y /)
(- (+ (expt x 2.0) (expt y 2.0))))
;;;Listado 19.19. Función para el cálculo de los vértices de un paraboloide de revolución.
(defun par-hip (x y /)
(- (expt x 2) (expt y 2)))
;;;Listado 19.20. Función para el cálculo de los vértices de un paraboloide hiperbólico.
(defun scp->u (/ tmp)
(setq tmp (ax-scp
"Univ"
'(0.0 0.0 0.0)
'(1.0 0.0 0.0)
'(0.0 1.0 0.0)))
(vla-put-ActiveUCS *aevl:dibujo* tmp))
;;;Listado 19.21. Función que establece como actual el sistema de coordenadas universal.
(defun datos-paraboloide (/)
(initget 1 "Entmod Activex")
(setq proc (getkword "Método: [Entmod/Activex]:"))
(if (= proc "Entmod")
(setq proc 'entmod-mesh)
(setq proc 'ax-mod-mesh))
(initget 1 "Revolución Hiperbólico")
(setq opcion (getkword
"\nTipo Paraboloide [Revolución/Hiperbólico]: "))
(cond
((= opcion "Revolución") (setq opcion 'par-rev))
((= opcion "Hiperbólico") (setq opcion 'par-hip)))
(initget 1 "Rectángulo Círculo Elipse eSfera")
(setq forma (getkword "\nForma [Rectángulo/Círculo/Elipse/eSfera]: "))
(if (= forma "Rectángulo")
(progn (initget "Centro Esquina")
(if
(not
(setq origen (getkword
"Origen [Centro/Esquina]<Centro>")))
(setq origen "Centro"))))
(initget 1)
(setq pos (getpoint "\nPosición de la malla: ")
z-malla (getdist pos "\nAltura de la malla: "))
(cond
((= forma "Rectángulo")
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nDimensión en X: "))
(initget (+ 1 2 4))
(setq dimY (getdist pos "\nDimensión en Y: "))
(initget (+ 1 2 4))
(setq dimZ (getdist pos "\nGrosor de la malla: "))
(initget (+ 1 2 4))
(setq prec (getint "\nResolución de la Malla: "))
(while (not (< 1 prec 257))
(prompt "\nLa Resolución debe ser de 2 a 256")
(initget (+ 1 2 4))
(setq prec (getint "\nResolución de la malla: "))))
((= forma "Círculo")
(initget (+ 2 4))
(if
(not
(setq prec (getint "\nSubdivisión del perímetro <20>:")))
(setq prec 20))
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nRadio de la Malla: ")
dimY dimX)
(initget (+ 1 2 4))
(setq dimZ (getdist pos "\nGrosor de la Malla: ")))
((= forma "Elipse")
(initget (+ 2 4))
(if
(not
(setq prec (getint "\nSubdivisión del perímetro <20>: ")))
(setq prec 20))
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nSemieje X de la Malla: "))
(initget (+ 1 2 4))
(setq dimY (getdist pos "\nSemieje Y de la Malla:"))
(initget (+ 1 2 4))
(setq dimZ (getdist pos "\nGrosor de la Malla: ")))
((= forma "eSfera")
(initget (+ 2 4))
(if (not (setq prec (getint "\nSubdivisión del ecuador <20>: ")))
(setq prec 20))
(initget (+ 1 2 4))
(setq dimX (getdist pos "\nRadio de la esfera: ")))))
;;;Listado 19.22. Función que solicita los datos para el paraboloide.
(defun C:PARABOLOIDE (/ *error* scp-actual proc opcion forma origen pos z-malla dimX
dimY dimZ prec obj)
(defun *error* (msg)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U")
(cmd-salir)
(prompt msg))
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq scp-actual (ax-matriz-scp)
mtrans (last scp-actual))
(scp->u))
(t (setq mtrans nil)))
(datos-paraboloide)
(cmd-entrar)
(cond
((= forma "Rectángulo")
(if (= origen "Centro")
(cmd-mesh-caja '(0 0 0) prec dimX dimY dimZ nil)
(cmd-mesh-caja '(0 0 0) prec dimX dimY dimZ t)))
((= forma "Círculo")
(cmd-mesh-cilindro '(0 0 0) prec dimX dimY dimZ))
((= forma "Elipse")
(cmd-mesh-cilindro '(0 0 0) prec dimX dimY dimZ))
((= forma "eSfera") (cmd-mesh-esfera '(0 0 0) prec dimX)))
(setq obj (vlax-ename->vla-object (entlast)))
(cmd-salir)
(if (= (vla-get-ObjectName obj) "AcDbSubDMesh")
(progn
(apply proc (list obj opcion z-malla))
(if mtrans
(progn
(vla-put-ActiveUCS
*aevl:dibujo*
(vla-item
(vla-get-UserCoordinateSystems
*aevl:dibujo*)
(car scp-actual)))
(vla-TransformBy obj mtrans)))
(ax-traslacion obj pos)
(ax-SOsup)))
(vla-EndUndoMark *aevl:dibujo*)
(princ))
;;;Listado 19.23. Función principal C:PARABOLOIDE.
(defun entmod-mesh-xyz (ename ecuacion dim-max eje / ent-list vertices i j k lst-mod
altura f-esc v-i v-j v-mod vertices-mod)
(if (eq (type ename) 'VLA-OBJECT)
(setq ename (vlax-vla-object->ename ename)))
(setq ent-list (entget ename)
vertices (valores 10 ent-list))
(cond
((= eje 0)
(setq i 1
j 2))
((= eje 1)
(setq i 0
j 2))
((= eje 2)
(setq i 0
j 1)))
(setq lst-mod (mapcar
'(lambda (vert)
(apply ecuacion
(list (nth i vert) (nth j vert))))
vertices)
altura (- (apply 'max lst-mod) (apply 'min lst-mod))
f-esc (/ dim-max altura))
(foreach vertex vertices
(setq v-i (nth i vertex)
v-j (nth j vertex)
v-mod (+ (nth eje vertex)
(* f-esc (apply ecuacion (list v-i v-j)))))
(cond
((= eje 0)
(setq vertices-mod (cons (list v-mod v-i v-j) vertices-mod)))
((= eje 1)
(setq vertices-mod (cons (list v-i v-mod v-j) vertices-mod)))
((= eje 2)
(setq vertices-mod (cons (list v-i v-j v-mod) vertices-mod)))))
(setq vertices-mod (reverse vertices-mod))
(setq k 0
nueva-lista ent-list)
(while (< k (length vertices))
(setq nueva-lista (subst (cons 10 (nth k vertices-mod))
(cons 10 (nth k vertices))
nueva-lista)
k (1+ k)))
(entmod nueva-lista)
(entupd ename))
;;;Listado 19.24. Función que deforma la malla en las direcciones X, Y o Z.
(defun C:FORMAR (/ ent eje ecuacion var-dim)
(vla-StartUndoMark *aevl:dibujo*)
(prompt "\nSelect MESH to shape: ")
(while (not (setq ent (ssget "_:S" '((0 . "MESH")))))
(prompt "\nSeleccione MESH para dar forma: "))
(initget (+ 2 4) "X Y Z")
(setq eje (getkword "\nIndique eje para transformación [X/Y/Z]<Z>"))
(cond
((= eje "X") (setq eje 0))
((= eje "Y") (setq eje 1))
(t (setq eje 2)))
(setq ent (ssname ent 0))
(initget 1)
(setq ecuacion (getstring "\nIndique función a emplear: "))
(cond
((car (atoms-family 0 (list ecuacion)))
(initget (+ 1 2 4))
(setq var-dim (getdist "\nAmplitud de la transformación: "))
(entmod-mesh-xyz ent (read ecuacion) var-dim eje))
(t
(prompt
(strcat "\nLa función "
ecuacion
" no está definida."))))
(vla-EndUndoMark *aevl:dibujo*)
(princ))
;;;Listado 19.25.Función principal C:FORMAR.
(defun cmd-mesh-cuadro (pt-ins lado div / x-min x-max y-min y-max z bordes)
(setvar "MESHTYPE" 1) ; objeto tipo MESH
(setvar "SURFTAB1" div) ; particiones U
(setvar "SURFTAB2" div) ; particiones V
(setq x-min (nth 0 pt-ins)
x-max (+ x-min lado)
y-min (nth 1 pt-ins)
y-max (+ y-min lado)
z (nth 2 pt-ins))
(vl-cmdf "_LINE" pt-ins (list x-max y-min z) "") ; Línea 1
(setq bordes (cons (entlast) bordes))
(vl-cmdf "_LINE"
(list x-max y-min z)
(list x-max y-max z)
"") ; Línea 2
(setq bordes (cons (entlast) bordes))
(vl-cmdf "_LINE"
(list x-max y-max z)
(list x-min y-max z)
"") ; Línea 3
(setq bordes (cons (entlast) bordes))
(vl-cmdf "_LINE" (list x-min y-max z) pt-ins "") ; Línea 4
(setq bordes (cons (entlast) bordes))
(apply 'vl-cmdf (cons "_EDGESURF" bordes)) ; Crear MESH
(mapcar 'entdel bordes) ; Borra las líneas
(princ))
;;;Listado 19.26. Creación de una MESH cuadrada plana mediante el comando SUPLADOS (_EDGESURF).
(defun datos-hiperb (/)
(initget 1)
(setq cen-base (getpoint "\nCentro de la base:"))
(initget (+ 1 2 4))
(setq rad-base (getdist cen-base "\nRadio de la base:"))
(initget (+ 1 2 4))
(setq altura (getdist cen-base "\nAltura del hiperboloide:"))
(initget 1)
(setq cen-sup (getpoint "\nCentro de la circunferencia superior:"))
(initget (+ 1 2 4))
(setq rad-sup (getdist cen-sup "\nRadio de la circunferencia superior:"))
(initget (+ 1 2 4))
(while (not (< 0.0 (setq ang (getreal "\nÁngulo de giro:")) 180.0))
(prompt "\nÁngulo debe ser mayor que 0º y menor que 180º")
(initget (+ 1 2 4)))
(setq ang (gar ang))
(initget (+ 2 4))
(if (not (setq n (getint "\nDivisiones de circunferencia <32>:")))
(setq n 32))
(initget (+ 2 4))
(if (not (setq k (getint "\nNivel de suavizado <2>:")))
(setq k 2))
(setvar "SURFTAB1" n)
(setvar "MESHTYPE" 1))
;;;Listado 19.27. Función que solicita los datos para el hiperboloide.
(defun ent-polcirc (elev radio capa)
(entmake
(list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
(cons 8 capa)
'(100 . "AcDbPolyline")
'(90 . 2)
'(70 . 1)
(cons 38 elev)
(cons 10 (list (- radio) 0.0))
'(42 . 1.0)
'(91 . 0)
(cons 10 (list radio 0.0))
'(42 . 1.0)
'(91 . 0))))
;;;Listado 19.28. Función que crea los perfiles circulares.
(defun ax-trans-rot (obj vector ang)
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos ang) (- (sin ang)) 0.0 (nth 0 vector))
(list (sin ang) (cos ang) 0.0 (nth 1 vector))
(list 0.0 0.0 1.0 (nth 2 vector))
(list 0.0 0.0 0.0 1.0)))))
;;;Listado 19.29. Función que traslada y gira un perfil.
(defun C:HIPERBOLOIDE (/ cen-base rad-base altura cen-sup rad-sup ang perfil-base
perfil-sup col-capas hiperb)
(datos-hiperb)
(cond
((ent-polcirc 0.0 rad-base "PERFILES")
(setq perfil-base (entlast))
(ax-trans-rot
(vlax-ename->vla-object perfil-base)
cen-base
0.0))
(t (prompt "\nERROR creando el perfil base.") (exit)))
(cond
((ent-polcirc altura rad-sup "PERFILES")
(setq perfil-sup (entlast))
(ax-trans-rot
(vlax-ename->vla-object perfil-sup)
cen-sup
ang))
(t (prompt "\nERROR creando el perfil superior.") (exit)))
(setq col-capas (vla-get-layers *aevl:dibujo*))
(vla-put-ActiveLayer
*aevl:dibujo*
(ax-capa col-capas "SUPERFICIE" "4" "Continuous"))
(if (vl-cmdf "_rulesurf" perfil-base perfil-sup)
(progn (setq hiperb (entlast))
(vla-put-smoothness (vlax-ename->vla-object hiperb) k)
(ax-SOsup))
(prompt "\nError creando el hiperboloide.")))
;;;Listado 19.30. Función principal C:HIPERBOLOIDE.
