;;;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 17. Modelado de Sólidos
(defun cmd-cono (ctrbase radbase radsup dim-z /)
(cmd-entrar)
(vl-cmdf "._CONE" ctrbase radbase)
(if (/= radsup 0)
(vl-cmdf "_t" radsup dim-z)
(vl-cmdf dim-z))
(cmd-salir))
;;;Listado 17.1. Creación de un cono mediante command/vl-cmdf.
(defun ax-cono (origen radio dim-z /)
(vla-AddCone
(espacio-actual *aevl:dibujo*)
(apply 'vlax-3d-point origen)
radio
dim-z))
;;;Listado 17.1. Creación de una primitiva del tipo Cono.
(defun ax-region (obj-espacio contornos / perfiles region)
(setq perfiles (vlax-make-safearray
vlax-vbobject
(cons 0 (1- (length contornos))))
perfiles (vlax-make-variant
(vlax-safearray-fill perfiles contornos))
region (vl-catch-all-apply
'vla-AddRegion
(list obj-espacio perfiles)))
(cond
((vl-catch-all-error-p region)
(prompt (vl-catch-all-error-message region)))
(t
(if (> (getvar "DELOBJ") 0)
(foreach loop contornos (vla-Delete loop)))
(vlax-safearray->list (vlax-variant-value region)))))
;;;Listado 17.3. Función que crea regiones según los contornos recibidos.
(defun ax-boolean (obj1 operacion obj2 / tmp)
(setq tmp (vl-catch-all-apply
'vla-Boolean
(list obj1 operacion obj2)))
(if (vl-catch-all-error-p tmp)
(prompt (vl-catch-all-error-message tmp))
obj1))
;;;Listado 17.4. Función que realiza una operación Booleana sobre dos objetos controlando errores.
(defun datos-region (/ radmax)
(initget 1)
(setq centro (getpoint "\nCentro de la región:"))
(initget (+ 1 2 4))
(setq radioext (getdist centro "\nRadio exterior:"))
(initget (+ 1 2 4))
(setq numag (getint "\nCantidad de agujeros:")
distcentro (* 2 (/ radioext 3.0))
radmax (apply 'min
(list (/ (* pi distcentro) (* numag 1.1))
(/ radioext 3.1))))
(initget (+ 1 2 4))
(setq radioag (getdist centro "\nRadio agujeros:"))
(while (>= radioag radmax)
(prompt
(strcat "\nEl radio de agujeros debe ser menor que "
(rtos radmax 2 2)))
(setq radioag (getdist centro "\nRadio agujeros:"))))
;;;Listado 17.5. Función que solicita los datos para la región compuesta.
(defun C:REG-COMP (/ mtrans obj-espacio mtrans centro radioext numag distcentro
radioag origen normal cir-base base ang incang cir-agujeros agujeros)
(setq obj-espacio (espacio-actual *aevl:dibujo*))
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-region)
(setq origen (vlax-3d-point '(0 0 0))
normal (vlax-3d-point '(0.0 0.0 1.0))
cir-base (vla-AddCircle obj-espacio origen radioext))
(vla-put-Normal cir-base normal)
(setq base (car (ax-region obj-espacio (list cir-base))))
(setq ang 0
incang (/ (* 2 pi) numag))
(repeat numag
(setq cir-agujeros (cons
(vla-AddCircle
obj-espacio
(vlax-3d-point
(polar '(0 0 0) ang distcentro))
radioag)
cir-agujeros)
ang (+ ang incang))
(vla-put-Normal (car cir-agujeros) normal))
(setq agujeros (ax-region obj-espacio cir-agujeros))
(foreach agujero agujeros (ax-boolean base acSubtraction agujero))
(if mtrans
(vla-TransformBy base mtrans))
(ax-traslacion base (trans centro 1 0 t))
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 17.6. Programa ejemplo para creación de regiones compuestas.
(defun reg-base (radioext numag distcentro radioag / obj-espacio origen normal
cir-base base ang incang circulos regiones)
(setq obj-espacio (espacio-actual *aevl:dibujo*)
origen (vlax-3d-point '(0 0 0))
normal (vlax-3d-point '(0.0 0.0 1.0))
cir-base (vla-AddCircle obj-espacio origen radioext))
(vla-put-Normal cir-base normal)
(setq base (car (ax-region obj-espacio (list cir-base))))
(setq ang 0
incang (/ (* 2 pi) numag))
(repeat numag
(setq circulos (cons
(vla-AddCircle
obj-espacio
(vlax-3d-point
(polar '(0 0 0) ang distcentro))
radioag)
circulos)
ang (+ ang incang))
(vla-put-Normal (car circulos) normal))
(setq regiones (ax-region obj-espacio circulos))
(foreach region regiones
(ax-boolean base acSubtraction region))
base)
;;;Listado 17.7. Función que crea la región compuesta usada como base.
(defun sol-hist (sol)
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History sol :vlax-true)))
;;;Listado 17.8. Activar la propiedad de Registro en un Sólido 3D.
(defun C:SOL-EXT (/ mtrans centro radioext numag radioag distcentro radioag dim-z
amax angc circ perfiles region extrusion)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-region)
(initget 1)
(setq dimZ (getdist centro "\nAltura de extrusión: ")
amax (- 90.0 (rag (atan (/ dimZ radioext)))))
(initget 1)
(setq angc (getreal "\nÁngulo de conicidad:"))
(while (not (<= -90.0 angc amax))
(setq angc (getreal
(strcat
"\nEl ángulo debe ser > -90º y < que "
(rtos amax)
"º"))))
(setq region (reg-base radioext numag distcentro radioag))
(setq angc (gar angc)
extrusion (vl-catch-all-apply
'vla-AddExtrudedSolid
(list (espacio-actual *aevl:dibujo*)
region
dimZ
angc)))
(cond
((vl-catch-all-error-p extrusion)
(prompt (vl-catch-all-error-message extrusion)))
(t
(sol-hist extrusion)
(if mtrans
(vla-TransformBy extrusion mtrans))
(ax-traslacion extrusion (trans centro 1 0 t))
(ax-SOsup)))
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 17.9. Creación de un Sólido de Extrusión.
(defun ax-ext-tray (obj-espacio perfil tray / res)
(if
(vl-catch-all-error-p
(setq res (vl-catch-all-apply
'vla-AddExtrudedSolidAlongPath
(list obj-espacio perfil tray))))
(princ (strcat "\nERROR: " (vl-catch-all-error-message res)))
(progn (sol-hist res) (vla-update res))))
;;;Listado 17.10. Función auxiliar ax-ext-tray.
(defun C:SOL-TRAY (/ obj-espacio tray perf inicio normal ptref desp)
(setq obj-espacio (espacio-actual *aevl:dibujo*))
(vla-StartUndoMark *aevl:dibujo*)
(while (not tray)
(prompt
(strcat "\nSeleccione la trayectoria "
"(Línea, LWPolyline, Arco, Círculo,"
" Elipse, Spline plana): "))
(setq tray (ssget "_:S"
'((-4 . "<OR")
(-4 . "<AND")
(0 . "SPLINE")
(-4 . "&")
(70 . 8)
(-4 . "AND>")
(-4 . "<AND")
(0 . "LWPOLYLINE,LINE,ARC,ELLIPSE,CIRCLE")
(-4 . "AND>")
(-4 . "OR>")))))
(while (not perf)
(prompt "\nSeleccione una Polilínea 2D como perfil. ")
(setq perf (ssget "_:S" '((0 . "LWPOLYLINE")))))
(setq tray (vlax-ename->vla-object (ssname tray 0))
perf (vlax-ename->vla-object (ssname perf 0)))
(if (= (vla-get-closed perf) :vlax-false)
(vla-put-closed perf :vlax-true))
(setq inicio (vlax-curve-GetPointAtParam
tray
(vlax-curve-GetStartParam tray))
normal (vlax-curve-GetFirstDeriv
tray
(vlax-curve-GetStartParam tray)))
(vla-TransformBy perf (ax-MTrans inicio normal))
(setq ptref (append
(vlax-safearray->list
(vlax-variant-value
(vla-get-coordinate perf 0)))
(list (vla-get-elevation perf)))
ptref (trans ptref (vlax-vla-object->ename perf) 0)
desp (mapcar '- inicio ptref))
(ax-traslacion perf desp)
(setq perf (car (ax-region obj-espacio (list perf))))
(ax-ext-tray obj-espacio perf tray)
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 17.11. Creación de un Sólido por barrido a lo largo de una trayectoria.
(defun cmd-helice-base ()
(cmd-entrar)
(vl-cmdf "_HELIX"
(trans '(0.0 0.0 0.0) 0 1)
(trans '(1.0 0.0 0.0) 0 1)
1.0
"_Turns"
1
"_Axis"
(trans '(0.0 0.0 1.0) 0 1))
(cmd-salir)
(vlax-ename->vla-object (entlast)))
;;;Listado 17.12. Función que crea un objeto HÉLICE mediante command/vl-cmdf.
(defun ent-helice-base ()
(if
(entmake
'((0 . "HELIX")
(100 . "AcDbEntity")
(100 . "AcDbSpline")
(70 . 0)
(71 . 3)
(72 . 8)
(73 . 4)
(74 . 0)
(42 . 1.0e-010)
(43 . 1.0e-010)
(40 . 0.0)
(40 . 0.0)
(40 . 0.0)
(40 . 0.0)
(40 . 0.628319)
(40 . 0.628319)
(40 . 0.628319)
(40 . 0.628319)
(10 1.0 0.0 0.0)
(10 1.0 0.20944 0.0333333)
(10 0.932122 0.418345 0.0666667)
(10 0.809017 0.587785 0.1)
(100 . "AcDbHelix")
(90 . 31)
(91 . 8)
(10 0.0 0.0 0.0)
(11 1.0 0.0 0.0)
(12 0.0 0.0 1.0)
(40 . 1.0)
(41 . 0.1)
(42 . 1.0)
(290 . 1)
(280 . 1)))
(entlast)))
;;;Listado 17.13. Función que crea una HÉLICE mediante entmake.
(defun ax-helice (posicion altura vueltas radiobase radiosup / obj)
(if (setq obj (vlax-ename->vla-object (ent-helice-base)))
(progn (vla-put-Height obj altura)
(vla-put-Turns obj vueltas)
(vla-put-BaseRadius obj radiobase)
(vla-put-TopRadius obj radiosup)
(vla-put-Position obj (vlax-3d-point posicion))
obj)))
;;;Listado 17.14. Función que crea la Hélice ajustando sus propiedades.
(defun prop-helix (posicion altura vueltas radbase radsup / obj)
(if (setq obj (ent-helice-base))
(progn (setpropertyvalue obj "Height" altura)
(setpropertyvalue obj "Turns" vueltas)
(setpropertyvalue obj "BaseRadius" radbase)
(setpropertyvalue obj "TopRadius" radsup)
(setpropertyvalue obj "Position" posicion))
obj))
;;;Listado 17.15. Función que crea la Hélice ajustando sus propiedades no-Com.
(defun datos-muelle (/ diamext diamhilo)
(initget 1)
(setq centro (getpoint "\nCentro de la base:"))
(initget (+ 1 2 4))
(setq diamext (getdist centro "\nDiámetro exterior: "))
(initget (+ 1 2 4))
(setq altura (getdist centro "\nLongitud del muelle: "))
(initget (+ 1 2 4))
(while
(> (setq diamhilo (getdist centro "\nDiámetro del hilo: "))
(/ diamext 5.0))
(prompt
(strcat "\nEl diámetro del hilo debe ser menor que "
(rtos (/ diamext 5.0) 2 2)))
(initget (+ 1 2 4)))
(initget (+ 1 2 4))
(while
(> 1
(setq vueltas (getint "\nNúmero de vueltas: "))
(fix (/ altura (* diamhilo 2))))
(prompt
(strcat "\nEl Número de vueltas debe ser menor que "
(itoa (fix (/ altura (* diamhilo 2))))))
(initget (+ 1 2 4)))
(setq radiohilo (/ diamhilo 2.0)
radiobase (- (/ diamext 2.0) radiohilo)))
;;;Listado 17.15. Solicitud al usuario de los datos para construir el muelle.
(defun cmd-barrido (perfil tray / csperfil cstray res)
(cmd-entrar)
(setq csperfil (ssadd)
cstray (ssadd))
(ssadd perfil csperfil)
(ssadd tray cstray)
(vl-cmdf "._SWEEP" csperfil "" cstray)
(cmd-salir)
(setq res (vlax-ename->vla-object (entlast)))
(sol-hist res)
res)
;;;Listado 17.16. Función que crea un sólido 3D utilizando el comando BARRIDO (_SWEEP).
(defun C:MUELLE (/ *error* mtrans obj-espacio mtrans centro altura vueltas radiohilo
radiobase tray ptref normal perfil reg-perfil obj-muelle)
(setq obj-espacio (espacio-actual *aevl:dibujo*))
(defun *error* ()
(cmd-salir)
(vla-EndUndoMark *aevl:dibujo*))
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-muelle)
(setq tray (ax-helice '(0 0 0) altura vueltas radiobase radiobase)
ptref (vlax-curve-GetPointAtParam
tray
(vlax-curve-GetStartParam tray))
normal (vlax-curve-GetFirstDeriv
tray
(vlax-curve-GetStartParam tray))
perfil (vl-catch-all-apply
'vla-AddCircle
(list obj-espacio
(vlax-3d-point ptref)
radiohilo)))
(cond
((vl-catch-all-error-p perfil)
(prompt (vl-catch-all-error-message perfil)))
(t
(vla-put-normal perfil (vlax-3d-point normal))
(setq reg-perfil (vlax-vla-object->ename
(car (ax-region obj-espacio (list perfil))))
tray (vlax-vla-object->ename tray))
(setq obj-muelle (cmd-barrido reg-perfil tray))
(if mtrans
(vla-TransformBy obj-muelle mtrans))
(ax-traslacion obj-muelle (trans centro 1 0 t))
(vla-Update obj-muelle)
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))))
;;;Listado 17.17. Función principal C:MUELLE.
(defun ax-sol-rev (obj-espacio perfil pt vector ang / res)
(if
(vl-catch-all-error-p
(setq res (vl-catch-all-apply
'vla-AddRevolvedSolid
(list obj-espacio
perfil
(vlax-3d-point pt)
(vlax-3d-point vector)
ang))))
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res)))
(progn (sol-hist res) (vla-Update res))))
;;;Listado 17.18. Función que crea un sólido por Revolución.
(defun C:SOL-REV (/ obj-espacio perf eje ang centro vec)
(setq obj-espacio (espacio-actual *aevl:dibujo*))
(vla-StartUndoMark *aevl:dibujo*)
(prompt "\nSeleccione el perfil:")
(while
(not
(setq perf (ssget
"_:S"
'((0 . "REGION,LWPOLYLINE,SPLINE,CIRCLE,ELLIPSE")))))
(prompt "\nSeleccione Region, Polilínea 2D, Círculo o Elipse:"))
(prompt "\nSeleccione el eje de revolución: ")
(while
(not
(setq eje (ssget "_:S"
'((-4 . "<AND")
(0 . "*LINE,ARC")
(-4 . "<NOT")
(-4 . "&")
(70 . 1)
(-4 . "NOT>")
(-4 . "AND>")))))
(prompt "\nSeleccione una entidad lineal abierta:"))
(initget (+ 2 4))
(if (not (setq ang (getreal "\nÁngulo de barrido <360>: ")))
(setq ang 360.0)
(while (> ang 360.0)
(initget (+ 2 4))
(setq ang (getreal "\nDebe ser menor que 360 <360>:"))))
(setq perf (vlax-ename->vla-object (ssname perf 0)))
(if (/= (vla-get-ObjectName perf) "AcDbRegion")
(cond
((and (vlax-property-available-p perf "Closed")
(= (vla-get-Closed perf) :vlax-false))
(if
(vl-catch-all-error-p
(vl-catch-all-apply
'vla-put-Closed
(list perf :vlax-true)))
(vla-put-Closed2 perf :vlax-true)))))
(setq perfiles (vlax-make-safearray vlax-vbObject '(0 . 0))
perfiles (vlax-make-variant
(vlax-safearray-fill perfiles (list perf)))
perf (vl-catch-all-apply
'vla-AddRegion
(list obj-espacio perfiles)))
(cond
((vl-catch-all-error-p perf)
(prompt
(strcat "ERROR:\t" (vl-catch-all-error-message perf))))
(t
(setq perf (vlax-safearray-get-element
(vlax-variant-value perf)
0))
(setq ang (gar ang)
eje (vlax-ename->vla-object (ssname eje 0)))
(if (= (vla-get-ObjectName eje) "AcDbXline")
(setq centro (vlax-safearray->list
(vlax-variant-value
(vla-get-BasePoint eje)))
vec (vlax-safearray->list
(vlax-variant-value
(vla-get-DirectionVector eje))))
(setq centro (vlax-curve-GetStartPoint eje)
vec (mapcar '- (vlax-curve-GetEndPoint eje) centro)))
(ax-sol-rev obj-espacio perf centro vec ang)
(ax-SOsup)))
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 17.19. Programa de ejemplo que crea un sólido de revolución.
(defun ax-props (obj / props valor pmin pmax bbox)
(setq props (vl-remove-if
'null
(mapcar
'(lambda (prop)
(if (vlax-property-available-p obj prop)
(progn
(setq valor (vl-catch-all-apply
'vlax-get-property
(list obj prop)))
(if (not (vl-catch-all-error-p valor))
(if (= (type valor) 'variant)
(cond
((>= (vlax-variant-type valor)
8192)
=
(cons
prop
(vlax-safearray->list
(vlax-variant-value
valor))))
((t
(cons
prop
(vlax-variant-value
valor)))))
(cons prop valor))))))
'("Centroid" "MomentOfInertia" "PrincipalDirections"
"PrincipalMoments" "ProductOfInertia" "RadiiOfGyration" "Volume"
"Area" "Circumference" "Radius" "Center" "Normal" "Perimeter"
"Coordinates" "FaceCount" "VertexCount" "Smoothness" "Elevation"
"ArcLength" "EndAngle" "EndPoint" "StartAngle" "StartPoint"
"TotalAngle" "Angle" "Delta" "Thickness" "BasePoint"
"DirectionVector" "SecondPoint" "BaseRadius" "Height" "Position"
"TopRadius" "TotalLength" "TurnHeight" "Turns" "TurnSlope" "Twist"
"Direction" "TaperAngle" "EndDraftAngle" "EndDraftMagnitude"
"NumCrossSections" "NumGuidePaths" "StartDraftAngle"
"StartDraftMagnitude" "SurfaceNormals" "SurfaceType"
"RevolutionAngle" "AxisPosition" "AxisDirection" "ProfileRotation"
"Bank" "Length" "ProfileRotation" "scale"))))
(setq bbox (vl-catch-all-apply
'vla-GetBoundingBox
(list obj 'pmin 'pmax)))
(if (vl-catch-all-error-p bbox)
props
(setq props (cons
(list "BoundingBox"
(vlax-safearray->list pmin)
(vlax-safearray->list pmax))
props))))
;;;Listado 17.20. Función que extrae propiedades físicas y geométricas de los objetos.
