;;;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 18. Edición de Sólidos 3D
(defun prop-hist (ent / reg mostrar)
(if
(=
(setq reg (valor-con-opciones
'getkword
"Registar Historia?: "
"Sí No"))
"No")
(setq reg 0)
(progn (setq reg 1)
(if
(=
(setq mostrar (valor-con-opciones
'getkword
"Mostrar Historial?: "
"Sí No"))
"No")
(setq mostrar 0)
(setq mostrar 1))))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("RecordHistory" "ShowHistory")
(list reg mostrar)))
;;;Listado 18.1. Establecer las propiedades del Historial de registros.
(defun prop-prisma (ent prim / pos h l w)
(setq pos (valor-por-defecto
'getpoint
(strcat "\nDesigne nueva posición del " prim ": ")
(getpropertyvalue ent "SolidPosition"))
h (valor-por-defecto
'getdist
(strcat "\nDesigne nueva altura del " prim ": ")
(getpropertyvalue ent "Height"))
l (valor-por-defecto
'getdist
(strcat "\nDesigne nueva longitud del " prim ": ")
(getpropertyvalue ent "Length"))
w (valor-por-defecto
'getdist
(strcat "\nDesigne nueva anchura del " prim ": ")
(getpropertyvalue ent "Width")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("SolidPosition" "Height" "Length" "Width")
(list pos h l w)))
;;;Listado 18.2. Modificar un PRISMA Sólido 3D.
(defun prop-cono (ent prim / pos h brmax brmin trmax)
(setq pos (valor-por-defecto
'getpoint
(strcat "\nDesigne nueva Posición del " prim ": ")
(getpropertyvalue ent "SolidPosition"))
h (valor-por-defecto
'getdist
(strcat "\nDesigne nueva Altura del " prim ": ")
(getpropertyvalue ent "Height")))
(if (= (getpropertyvalue ent "Elliptical") 0)
(progn
(setq brmax (valor-por-defecto
'getdist
(strcat "\nDesigne Radio Base del " prim ": ")
(getpropertyvalue ent "BaseRadius"))
trmax (valor-por-defecto
'getdist
(strcat "\nDesigne Radio Superior del " prim ": ")
(getpropertyvalue ent "TopRadius")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("SolidPosition" "Height" "BaseRadius" "TopRadius")
(list pos h brmax trmax)))
(progn
(setq brmax (valor-por-defecto
'getdist
(strcat "\nDesigne Radio Base Mayor del "
prim
": ")
(getpropertyvalue ent "BaseMajorRadius")))
(while
(>
(setq brmin (valor-por-defecto
'getdist
(strcat "\nDesigne Radio Base Menor del "
prim
": ")
(getpropertyvalue ent "BaseMinorRadius")))
brmax)
(prompt
(strcat "Radio Menor debe ser menos que " (rtos brmax))))
(setq trmax (valor-por-defecto
'getdist
(strcat "\nDesigne Radio Superior Menor del "
prim
": ")
(getpropertyvalue ent "TopMinorRadius")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("SolidPosition" "Height" "BaseMajorRadius" "BaseMinorRadius"
"TopMinorRadius")
(list pos h brmax brmin trmax)))))
;;;Listado 18.3. Modificar una primitiva CONO Sólido 3D.
(defun prop-loft (ent prim / normtyp sda sdm eda edm)
(setq normtyp (valor-con-opciones
'getkword
(strcat "Tipo de Normales a la entidad " prim " : ")
"Suave Primera Ultima Final Todo Angulos Reglada"))
(cond
((= normtyp "Suave") (setpropertyvalue ent "NormalType" 0))
((= normtyp "Primera") (setpropertyvalue ent "NormalType" 1))
((= normtyp "Ultima") (setpropertyvalue ent "NormalType" 2))
((= normtyp "Final") (setpropertyvalue ent "NormalType" 3))
((= normtyp "Todo") (setpropertyvalue ent "NormalType" 4))
((= normtyp "Angulos")
(setpropertyvalue ent "NormalType" 5)
(setq sda (gar
(valor-por-defecto
'getreal
"\nDesigne Ángulo Inicial "
(gar
(getpropertyvalue
ent
"LoftOptions/StartDraftAngle"))))
sdm (valor-por-defecto
'getdist
(strcat "\nDesigne Magnitud inicial: ")
(getpropertyvalue
ent
"LoftOptions/StartDraftMagnitude"))
eda (gar
(valor-por-defecto
'getreal
(strcat "\nDesigne Ángulo Final:")
(gar
(getpropertyvalue
ent
"LoftOptions/EndDraftAngle"))))
edm (valor-por-defecto
'getdist
(strcat "\nDesigne Magnitud Final: ")
(getpropertyvalue ent "LoftOptions/EndDraftMagnitude")))
(mapcar '(lambda (p n) (setpropertyvalue ent p n))
'("LoftOptions/StartDraftAngle" "LoftOptions/StartDraftMagnitude"
"LoftOptions/EndDraftAngle" "LoftOptions/EndDraftMagnitude")
(list sda sdm eda edm)))
((= normtyp "Reglada") (setpropertyvalue ent "NormalType" 6))))
;;;Listado 18.4. Modificar un Solido 3D por SOLEVACIÓN (LOFT).
(defun C:SOL-PROPS (/ ent prim)
(setq ent (car (entsel)))
(if
(and (= (cdr (assoc 0 (entget ent))) "3DSOLID")
(= (getpropertyvalue ent "IsPrimitive") 1)
(setq prim (getpropertyvalue ent "SolidType")))
(cond
((or (= prim "Prisma") (= prim "Box"))
(prop-prisma ent prim))
((or (= prim "Cono") (= prim "Cone"))
(prop-cono ent prim))
((or (= (substr prim 1 7) "Solevar") (= (substr prim 1 4) "Loft"))
(prop-loft ent prim))
(t (prompt (strcat "\nPrimitiva " prim " no soportada! "))))
(prompt
(strcat "\Objeto " (cdr (assoc 0 (entget ent))) " no soportado!.")))
(princ))
;;;Listado 18.5. Comando para modificar propiedades de 3DSolidos.
(defun ax-corte (obj punto1 punto2 punto3 negativo / res)
(setq res (vl-catch-all-apply
'vla-SliceSolid
(list obj
(vlax-3d-point punto1)
(vlax-3d-point punto2)
(vlax-3d-point punto3)
negativo)))
(if (vl-catch-all-error-p res)
(prompt (vl-catch-all-error-message res))
res))
;;;Listado 18.6. Función que realiza el corte del sólido.
(defun datos-sol-p (/)
(initget 1 "Tetraedro Hexaedro Dodecaedro")
(setq clase (getkword
"\nPoliedro [Tetraedro/Hexaedro/Dodecaedro]:")
centro (getpoint "\nCentro del Poliedro: ")
radio (getdist centro "\Radio de la esfera circunscrita: ")))
;;;Listado 18.7. Función datos-sol-p que solicita la entrada de datos al usuario.
(defun C:SOL-POLIEDRO (/ mtrans clase centro radio esfera)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-sol-p)
(op-poliedro clase)
(setq esfera (vl-catch-all-apply
'vla-AddSphere
(list (espacio-actual *aevl:dibujo*)
(vlax-3d-point '(0 0 0))
1.0)))
(cond
((vl-catch-all-error-p esfera)
(prompt (vl-catch-all-error-message esfera)))
(t
(sol-hist esfera)
(foreach cara caras
(ax-corte
esfera
(nth (1- (car cara)) vertices)
(nth (1- (cadr cara)) vertices)
(nth (1- (caddr cara)) vertices)
:vlax-false))
;; Transformaciones:
(ax-escala esfera (list radio radio radio))
(if mtrans
(vla-TransformBy esfera mtrans))
(ax-traslacion esfera (trans centro 1 0 t))
(vla-Update esfera)
(ax-SOsup)))
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.8. Función principal C:SOL-POLIEDRO.
(defun ax-secciona (obj punto1 punto2 punto3 / res)
(setq res (vl-catch-all-apply
'vla-SectionSolid
(list obj
(vlax-3d-point punto1)
(vlax-3d-point punto2)
(vlax-3d-point punto3))))
(if (vl-catch-all-error-p res)
(prompt (vl-catch-all-error-message res))
res))
;;;Listado 18.9. Función que crea la sección del sólido como Región.
(defun C:SECC-POLIEDRO (/ mtrans clase centro radio esfera regiones)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-sol-p)
(op-poliedro clase)
(setq esfera (vl-catch-all-apply
'vla-AddSphere
(list (espacio-actual *aevl:dibujo*)
(vlax-3d-point '(0 0 0))
1.0)))
(cond
((vl-catch-all-error-p esfera)
(prompt (vl-catch-all-error-message esfera)))
(t
(sol-hist esfera)
(foreach cara caras
(setq regiones (cons
(ax-secciona
esfera
(nth (1- (car cara)) vertices)
(nth (1- (cadr cara)) vertices)
(nth (1- (caddr cara)) vertices))
regiones)))
(if (> (getvar "DELOBJ") 0)
(vla-Delete esfera))
(foreach region regiones ; Transformaciones:
(ax-escala region (list radio radio radio))
(if mtrans
(vla-TransformBy region mtrans))
(ax-traslacion region (trans centro 1 0 t)))
(ax-SOsup)))
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.10. Función principal C:SECC-POLIEDRO.
(defun datos-conector (/ maxdiam)
(setq origen '(0.0 0.0 0.0)
centro (getpoint "\nDesigne centro del conector:")
calibre (getdist centro "\nDesigne calibre:")
maxdiam (* calibre 2.5))
(initget (+ 2 4))
(while (or (not diam) (> diam maxdiam))
(setq diam (getreal
(strcat "\nDiámetro de los agujeros <"
(rtos (* calibre 2))
">: ")))
(cond
((not diam) (setq diam (* calibre 2)))
(t
(if (> diam maxdiam)
(prompt
(strcat
"\nEl diámetro del agujero debe ser menor que "
(rtos maxdiam 2 2))))
(initget (+ 2 4)))))
(cond
((= (getvar "SOLIDHIST") 0)
(initget 1 "Si No")
(if
(equal (getkword "\n¿Activar el Historial del sólido? [Si/No]:")
"Yes")
(setvar "SOLIDHIST" 1)))))
;;;Listado 18.11. Entrada de datos para el conector.
(defun ax-cubo (centro lado / res)
(setq res (vl-catch-all-apply
'vla-AddBox
(list (espacio-actual *aevl:dibujo*)
(vlax-3d-point centro)
lado
lado
lado)))
(cond
((vl-catch-all-error-p res)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res))))
(t
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History res :vlax-true))
res)))
;;;Listado 18.12. Función utilizada para crear los cubos como Sólidos 3D.
(defun ax-cilindro (centro radio dim-z / res)
(setq res (vl-catch-all-apply
'vla-AddCylinder
(list (espacio-actual *aevl:dibujo*)
(vlax-3d-point centro)
radio
dim-z)))
(cond
((vl-catch-all-error-p res)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res))))
(t
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History res :vlax-true))
res)))
;;;Listado 18.13. Función utilizada para crear los cilindros como Sólidos 3D.
(defun rot-90-x (obj / ang)
(setq ang (/ pi 2))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list 1.0 0.0 0.0 0.0)
(list 0.0 (cos ang) (sin ang) 0.0)
(list 0.0 (- (sin ang)) (cos ang) 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listado 18.14. Función que gira un objeto 90º en torno al eje X.
(defun rot-90-y (obj / ang)
(setq ang (/ pi 2))
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos ang) 0.0 (sin ang) 0.0)
(list 0.0 1.0 0.0 0.0)
(list (- (sin ang)) 0.0 (cos ang) 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listado 18.15. Función que gira un objeto 90º en torno al eje Y.
(defun elimina-duplicados (lst / tmp)
(while lst
(setq tmp (cons (car lst) tmp)
lst (vl-remove-if
'(lambda (a) (equal a (car tmp) 0.0001))
lst)))
(reverse tmp))
;;;Listado 18.16. Función que elimina duplicados en una lista.
(defun C:CONECTOR (/ mtrans origen centro calibre lado diam desp posiciones centros base dif)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-conector)
(setq lado (* calibre 7)
base (ax-cubo origen lado)
desp (list (/ lado 2.0)
(/ lado 2.0)
(/ lado 2.0))
posiciones '((1 1 1)
(1 1 -1)
(1 -1 1)
(1 -1 -1)
(-1 1 1)
(-1 1 -1)
(-1 -1 1)
(-1 -1 -1))
centros (mapcar '(lambda (pos) (mapcar '* desp pos)) posiciones)
lado (* calibre 6))
(mapcar
'(lambda (ctr)
(setq dif (ax-cubo ctr lado))
(vla-Boolean base acSubtraction dif))
centros)
(setq lado (* calibre 2.0)
desp (list lado lado 0.0)
centros (elimina-duplicados
(mapcar '(lambda (pos) (mapcar '* desp pos)) posiciones)))
(mapcar
'(lambda (ctr)
(setq dif (ax-cilindro ctr (/ diam 2.0) lado))
(vla-Boolean base acSubtraction dif))
centros)
(mapcar
'(lambda (ctr)
(setq dif (ax-cilindro ctr (/ diam 2.0) lado))
(rot-90-y dif)
(vla-Boolean base acSubtraction dif))
centros)
(mapcar
'(lambda (ctr)
(setq dif (ax-cilindro ctr (/ diam 2.0) lado))
(rot-90-x dif)
(vla-Boolean base acSubtraction dif))
centros)
(if mtrans
(vla-TransformBy base mtrans))
(ax-traslacion base (trans centro 1 0 t))
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.17. Función principal C:CONECTOR.
(defun datos-eslabon (/)
(initget 1)
(setq centro (getpoint "\nCentro del eslabón:"))
(initget (+ 1 2 4))
(setq dim-x (getdist centro "\nLongitud del eslabón:")
origen '(0.0 0.0 0.0)
r (/ dim-x 2.0))
(cond
((= (getvar "SOLIDHIST") 0)
(initget 1 "Si No")
(if
(equal (getkword "\n¿Activar el Historial del sólido? [Si/No]:")
"Si")
(setvar "SOLIDHIST" 1)))))
;;;Listado 18.18. Función que solicita los datos para el eslabón.
(defun ax-caja (centro dim-x dim-y dim-z / res)
(setq res (vl-catch-all-apply
'vla-AddBox
(list (espacio-actual *aevl:dibujo*)
(vlax-3d-point centro)
dim-x
dim-y
dim-z)))
(cond
((vl-catch-all-error-p res)
(prompt
(strcat "\nERROR: " (vl-catch-all-error-message res))))
(t
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History res :vlax-true))
res)))
;;;Listado 18.19. Función ax-caja que crea un Sólido 3D en forma de prisma rectangular.
(defun rot-180-z (obj /)
(vla-TransformBy
obj
(vlax-tmatrix
(list (list (cos pi) (- (sin pi)) 0.0 0.0)
(list (sin pi) (cos pi) 0.0 0.0)
(list 0.0 0.0 1.0 0.0)
(list 0.0 0.0 0.0 1.0)))))
;;;Listado 18.20. Función que gira un objeto 180º en torno al eje Z.
(defun C:ESLABON (/ mtrans origen centro dim-x r base hueco caja1 caja2)
(vla-StartUndoMark *aevl:dibujo*)
(cond
((= (getvar "WORLDUCS") 0)
(setq mtrans (last (ax-matriz-scp))))
(t (setq mtrans nil)))
(datos-eslabon)
(setq base (ax-cilindro (list r 0.0 0.0) r (* r 2))
hueco (ax-cilindro (list r 0.0 0.0) (/ r 2.0) (* r 2))
caja1 (ax-caja
(list (- (* 0.5 r)) 0.0 0.0)
(* 3 r)
(* 2 r)
(* 2 r))
caja2 (ax-caja (list (- r) 0.0 0.0) (* 2 r) r (* r 2)))
(vla-Boolean base acUnion caja1)
(vla-Boolean base acSubtraction caja2)
(vla-Boolean base acSubtraction hueco)
(setq copia-base (vla-Copy base))
(rot-90-x copia-base)
(rot-180-z copia-base)
(vla-Boolean base acIntersection copia-base)
(if mtrans
(vla-TransformBy base mtrans))
(ax-traslacion base (trans centro 1 0 t))
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.21. Función principal C:ESLABON.
(defun recortador (cortante a-cortar / tmp)
(setq tmp (if (>= (atoi (getvar "acadver")) 19)
(vl-catch-all-apply
'vla-CheckInterference
(list cortante
a-cortar
:vlax-true
'SolidosInterfieren))
(vl-catch-all-apply
'vla-CheckInterference
(list cortante a-cortar :vlax-true))))
(cond
((vl-catch-all-error-p tmp)
(prompt (vl-catch-all-error-message tmp)))
((null tmp)
(prompt "\nLos Sólidos seleccionados no se interfieren."))
(tmp
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History a-cortar :vlax-true))
(vl-catch-all-apply
'vla-Boolean
(list a-cortar acSubtraction tmp))))
(princ))
;;;Listado 18.22. Función que recorta un Sólido 3D de otro.
(defun C:SOL-RECORTA (/ cortante recortado a-cortar *error*)
(vl-load-com)
(defun *error* (msg)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U")
(prompt msg))
(vla-StartUndoMark *aevl:dibujo*)
(prompt "\Designe Sólido 3D cortante: ")
(setq cortante (vlax-ename->vla-object
(ssname (ssget "_:S" '((0 . "3DSOLID"))) 0)))
(prompt "\Designe Sólidos 3D a recortar: ")
(setq recortado (ssget '((0 . "3DSOLID")))
i 0)
(repeat (sslength recortado)
(setq a-cortar (vlax-ename->vla-object (ssname recortado i)))
(recortador cortante a-cortar)
(setq i (1+ i)))
(ax-SOsup)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.23. Función principal C:RECORTAR.
(defun s-separa (obj /)
(vl-cmdf "_solidedit"
"_body"
"_separate"
(vlax-vla-object->ename obj)
"_exit"
"_exit"))
;;;Listado 18.24. Función que separa Sólidos 3D compuestos.
(defun divisor (obj1 obj2 / interf tmp res)
(setq interf (if (>= (atoi (getvar "acadver")) 19)
(vl-catch-all-apply
'vla-CheckInterference
(list obj1 obj2 :vlax-true 'SolidosInterfieren))
(vl-catch-all-apply
'vla-CheckInterference
(list obj1 obj2 :vlax-true))))
(cond
((vl-catch-all-error-p interf)
(prompt (vl-catch-all-error-message interf)))
(interf
(if (= (getvar "SOLIDHIST") 1)
(vla-put-History interf :vlax-true))
(setq tmp (vla-Copy interf))
(setq res (vl-catch-all-apply
'vla-Boolean
(list obj1 acSubtraction tmp)))
(if (not (vl-catch-all-error-p res))
(s-separa obj1))
(setq tmp (vla-Copy interf))
(setq res (vl-catch-all-apply
'vla-Boolean
(list obj2 acSubtraction tmp)))
(if (not (vl-catch-all-error-p res))
(s-separa obj2))))
obj1)
;;;Listado 18.25. Función que crea nuevos Sólidos a partir de los volúmenes superpuestos.
(defun C:SOL-DIVIDE (/ a-dividir base obj *error*)
(vl-load-com)
(defun *error* (msj)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U")
(prompt msj))
(vla-StartUndoMark *aevl:dibujo*)
(prompt "\Designe los Sólidos 3D a dividir: ")
(setq a-dividir (ssget '((0 . "3DSOLID")))
i 0
j 0)
(repeat (sslength a-dividir)
(setq base (vlax-ename->vla-object (ssname a-dividir i)))
(repeat (sslength a-dividir)
(setq obj (vlax-ename->vla-object (ssname a-dividir j)))
(if (not (equal base obj))
(setq base (divisor base obj)))
(setq j (1+ j)))
(setq i (1+ i)
j 0))
(ax-SOsup)
(setvar "VSFACEOPACITY" 50)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.26. Función principal C:DIVIDE.
(defun ent-seccion (lst-pt vectorplano nombre alturasuperior alturainferior /)
(entmake
(append
(list '(0 . "SECTIONOBJECT")
'(100 . "AcDbEntity")
'(100 . "AcDbSection")
(cons 1 nombre) ;Nombre
(cons 10 vectorplano) ;Dir. Vertical
(cons 40 alturasuperior) ;Ext. Superior
(cons 41 alturainferior) ;Ext. Inferior
(cons 92 (length lst-pt))) ;Núm. Vértices
(mapcar '(lambda (pt) (cons 11 pt)) lst-pt))))
;;;Listado 18.27. Función que crea una entidad SECTION usando ENTMAKE.
(defun ax-seccion (lst-pt vectorplano / obj-seccion i pt)
(setq obj-seccion (vla-AddSection
(espacio-actual *aevl:dibujo*)
(vlax-3d-point (nth 0 lst-pt))
(vlax-3d-point (nth 1 lst-pt))
(vlax-3d-point vectorplano)))
(setq i 2)
(while (setq pt (nth i lst-pt))
(vla-AddVertex obj-seccion i (vlax-3d-point pt))
(setq i (1+ i)))
obj-seccion)
;;;Listado 18.28. Función que crea una Sección usando métodos y propiedades ActiveX.
(defun geom-secc (obj-seccion modelo-3d nombre / objs objs-contornoint
objs-rellenoint objs-fondo objs-frente objs-tangcurva)
(vla-GenerateSectionGeometry obj-seccion modelo-3d 'objs-contornoint
'objs-rellenoint 'objs-fondo 'objs-frente 'objs-tangcurva)
(setq objs (apply
'append
(mapcar
'(lambda (a)
(if (>= (vlax-safearray-get-u-bound a 1) 0)
(vlax-safearray->list a)))
(list objs-contornoint objs-rellenoint objs-fondo objs-frente
objs-tangcurva))))
(ax-suma-grupo
nombre
(apply
'append
(mapcar
'(lambda (a)
(if (>= (vlax-safearray-get-u-bound a 1) 0)
(vlax-safearray->list a)))
(list objs-contornoint objs-rellenoint objs-fondo objs-frente objs-tangcurva)))))
;;;Listado 18.29. Función que crea la geometría de la Sección.
(defun crea-capas (nombre separador lista-capas / capa col-capas res)
(setq col-capas (vla-get-Layers *aevl:dibujo*))
(foreach capa lista-capas
(setq capa (strcat nombre separador capa))
(setq res (vl-catch-all-apply 'vla-Item (list col-capas capa)))
(if (vl-catch-all-error-p res)
(vla-Add col-capas capa))))
;;;Listado 18.30. Función que añade Capas al dibujo.
(defun props-secc (obj-seccion dim nombre alturasuperior alturainferior dirvista /
ajustes ajust-tipo-secc clr)
(vla-put-name obj-seccion nombre)
(vla-put-TopHeight obj-seccion alturasuperior)
(vla-put-BottomHeight obj-seccion alturainferior)
(vla-put-ViewingDirection obj-seccion (vlax-3d-point dirvista))
(vla-put-TrueColor obj-seccion (vla-get-IndicatorFillColor obj-seccion))
(vla-put-Layer obj-seccion (strcat nombre "_Seccion"))
(vla-put-State2 obj-seccion acSectionStatePlane) ;SectionState
(setq ajustes (vla-get-Settings obj-seccion))
(vla-put-CurrentSectionType ajustes acSectionType2dSection) ;SectionType
(setq ajust-tipo-secc (vla-GetSectionTypeSettings
ajustes
acSectionType2dSection)) ;Ajustes SectionType
;;Capas-----------------------------------------------------
(vla-put-BackgroundLinesLayer ;Capas
ajust-tipo-secc
(strcat nombre "_" "LineasFondo"))
(vla-put-CurveTangencyLinesLayer
ajust-tipo-secc
(strcat nombre "_" "LineasTangCurva"))
(vla-put-ForegroundLinesLayer
ajust-tipo-secc
(strcat nombre "_" "LineasFrente"))
(vla-put-IntersectionBoundaryLayer
ajust-tipo-secc
(strcat nombre "_" "ContornoIntersecc"))
(vla-put-IntersectionFillLayer
ajust-tipo-secc
(strcat nombre "_" "RellenoIntersecc"))
;;Visibilidad----------------------------------------------
(vla-put-CurveTangencyLinesVisible ;Visibilidad
ajust-tipo-secc
:vlax-false)
(vla-put-ForegroundLinesVisible ajust-tipo-secc :vlax-false)
(vla-put-IntersectionFillVisible ajust-tipo-secc :vlax-true)
(vla-put-ForegroundLinesLinetype ajust-tipo-secc "byLayer")
(vla-put-BackgroundLinesLinetype ajust-tipo-secc "byLayer")
(vla-put-IntersectionFillLinetype ajust-tipo-secc "byLayer")
(vla-put-IntersectionBoundaryLinetype ajust-tipo-secc "byLayer")
(vla-put-BackgroundLinesHiddenLine ajust-tipo-secc :vlax-true)
(vla-put-BackgroundLinesLineweight ajust-tipo-secc acLnWt000)
(vla-put-IntersectionFillLineweight ajust-tipo-secc acLnWt000)
(vla-put-IntersectionBoundaryLineweight ajust-tipo-secc acLnWt030)
(setq clr (vla-get-IntersectionBoundaryColor ajust-tipo-secc))
(vla-put-ColorIndex clr acBylayer)
(vla-put-IntersectionBoundaryColor ajust-tipo-secc clr)
(vla-put-IntersectionFillColor ajust-tipo-secc clr)
(vla-put-ForegroundLinesColor ajust-tipo-secc clr)
(vla-put-CurveTangencyLinesColor ajust-tipo-secc clr)
(vla-put-BackgroundLinesColor ajust-tipo-secc clr)
(vla-put-IntersectionFillHatchPatternType
ajust-tipo-secc
acHatchPatternTypeUserDefined)
(vla-put-IntersectionFillHatchPatternName
ajust-tipo-secc
"_U")
(vla-put-IntersectionFillHatchAngle ajust-tipo-secc (/ pi 4))
(vla-put-IntersectionFillHatchSpacing
ajust-tipo-secc
(/ dim 60)))
;;;Listado 18.31. Propiedades de la entidad SECTION.
(defun datos-secc (/ opc ptoMin ptoMax xmin ymin zmin xmax ymax zmax dx dy dz)
(initget "Superior Frente Lado")
(if (not (setq opc (getkword "\nVista [Superior/Frente/Lado] <Superior>:")))
(setq opc "Superior"))
(initget 1)
(setq nombre (getstring "\nNombre de la Sección:"))
(prompt "\Designe Sólido 3D a seccionar:")
(while (not (setq obj (ssget "_:S" '((0 . "3DSOLID")))))
(prompt "\Designe Sólido 3D a seccionar:"))
(setq obj (vlax-ename->vla-object (ssname obj 0)))
(vla-GetBoundingBox obj 'ptoMin 'ptoMax)
(cond
((and ptoMin ptoMax)
(setq ptoMin (vlax-safearray->list ptoMin)
ptoMax (vlax-safearray->list ptoMax)
xmin (nth 0 ptoMin)
ymin (nth 1 ptoMin)
zmin (nth 2 ptoMin)
xmax (nth 0 ptoMax)
ymax (nth 1 ptoMax)
zmax (nth 2 ptoMax)
dx (- xmax xmin)
dy (- ymax ymin)
dz (- zmax zmin)
dmin (min dx dy dz))
(ops-secc opc dy dz xmin ymin xmax ymax zmax))))
;;;Listado 18.32. Función de entrada de datos.
(defun ops-secc (opc dy dz xmin ymin xmax ymax zmax /)
(cond
((= opc "Superior")
(setq vectorPlano '(0 1 0)
dirvista '(0 0 1)
alturainferior (* dy 0.2)
alturasuperior (+ dy alturainferior)
lst-pt (list
(list (- xmin alturainferior)
ymin
(/ (+ zmin zmax) 2.0))
(list (+ xmax alturainferior)
ymin
(/ (+ zmin zmax) 2.0)))))
((= opc "Frente")
(setq vectorPlano '(0 0 1)
dirvista '(0 -1 0)
alturainferior (* dz 0.2)
alturasuperior (+ dz alturainferior)
lst-pt (list
(list (- xmin alturainferior)
(/ (+ ymin ymax) 2.0)
zmin)
(list (+ xmax alturainferior)
(/ (+ ymin ymax) 2.0)
zmin))))
((= opc "Lado")
(setq vectorPlano '(0 0 1)
dirvista '(-1 0 0)
alturainferior (* dz 0.2)
alturasuperior (+ dz alturainferior)
lst-pt (list
(list (/ (+ xmin xmax) 2.0)
(- ymin alturainferior)
zmin)
(list (/ (+ xmin xmax) 2.0)
(+ ymax alturainferior)
zmin))))))
;;;Listado 18.33. Opciones de la Sección.
(defun C:SECC-SOL (/ *error* opc nombre obj obj-seccion vectorplano dirvista
alturainferior alturasuperior lst-pt)
(defun *error* (msj)
(vla-EndUndoMark *aevl:dibujo*)
(command-s "_U")
(prompt msj))
(vla-StartUndoMark *aevl:dibujo*)
(datos-secc)
(crea-capas
nombre
"_"
'("Seccion" "LineasFondo" "LineasTangCurva" "LineasFrente"
"ContornoIntersecc" "RellenoIntersecc"))
(setq obj-seccion (ax-seccion lst-pt vectorplano))
(props-secc obj-seccion dmin nombre alturasuperior alturainferior dirvista)
(geom-secc obj-seccion obj nombre)
(vla-EndUndoMark *aevl:dibujo*))
;;;Listado 18.34. Función principal C:SECC-SOL.
