Código Fuente‎ > ‎

Capítulo 18.lsp

;;;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 pi0.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 10
                      (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 10
             (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.
Comments