Código Fuente‎ > ‎

Capítulo 15.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 15

(defun ax-longcurva  (objcurva)
  (vlax-curve-GetDistAtParam
    objcurva
    (vlax-curve-GetEndParam objcurva)))
;;;Listado 15.1. Determinación de la longitud total de una curva.

(defun C:LEE-LONGITUD  (/ obj)
  (if (setq obj (car (entsel "\nDesigne Curva a medir:")))
    (alert
      (strcat "El objeto "
              (cdr (assoc 0 (entget obj)))
              " mide\n"
              (vl-princ-to-string
                (ax-longcurva (vlax-ename->vla-object obj)))
              " unidades de longitud."))
    (alert "Ningún objeto seleccionado.")))
;;;Listado 15.2. Función de prueba para AX-LONGCURVA.

(defun ax-dist-punto  (objCurva pt / param)
  (if (setq param 
             (vlax-curve-GetParamAtPoint objCurva (trans pt 1 0)))
    (vlax-curve-GetDistAtParam objCurva param)))
;;;Listado 15.3. Longitud desde el inicio a un punto cualquiera.

(defun C:DIST-A-PUNTO  (/ obj pt dist)
  (prompt "\nDesigne Curva a medir: ")
  (cond
    ((setq obj (car (entsel)))
     (setq obj  (vlax-ename->vla-object obj)
           dist (ax-dist-punto obj (getpoint "\nSeleccione Punto: ")))
     (alert (if dist
         (strcat
           "\nLa distancia desde el inicio"
           "\nhasta el punto designado es\n"
           (rtos dist 2 2))
         "El punto no se encuentra sobre el objeto")))
    (t (alert "Ningún objeto designado"))))
;;;Listado 15.4. Programa que mide la distancia desde el inicio a un punto a lo largo de una curva.

(defun ax-dist-entrepuntos
       (objCurva pt1 pt2 / dist1 dist2)
  (if (and (setq dist1 (ax-dist-punto objCurva pt1))
           (setq dist2 (ax-dist-punto objCurva pt2)))
    (abs (- dist1 dist2))))
;;;Listado 15.5. Longitud entre dos puntos de la curva.

(defun C:DIST-ENTRE-PUNTOS  (/ obj pt1 pt2 dist)
  (prompt "\nDesigne Curva a medir: ")
  (if (and (setq obj (car (entsel)))
           (setq pt1 (getpoint "\nPunto 1: "))
           (setq pt2 (getpoint "\nPunto 2: "))
           (setq dist
                  (ax-dist-entrepuntos
                    (vlax-ename->vla-object obj)
                    pt1
                    pt2)))
    (alert (strcat "\nLa distancia entre los puntos"
              "\nes igual a \n"
              (rtos dist 2 2)))
    (alert (if (null obj)
        "Ningún objeto designado"
        "El punto no está sobre el objeto"))))
;;;Listado 15.6. Programa que mide la distancia entre dos puntos a lo largo de una curva.

(defun C:AREA-CURVA  (/ obj nombre)
  (while (setq obj (car (entsel)))
    (setq obj (vlax-ename->vla-object obj)
          nombre (vlax-get-property obj "ObjectName"))
    (cond
      ((not (vlax-property-available-p obj "Area"))
       (alert
         (strcat "El objeto "
           nombre
           " seleccionado\nNO tiene Área.")))
      ((not (vlax-curve-isPlanar obj))
       (alert
         (strcat "El objeto "
                 nombre
                 " seleccionado\nNO es plano.")))
      ((not (vlax-curve-isClosed obj))
       (alert
         (strcat "El objeto "
           nombre
           " seleccionado\nNO está cerrado.")))
      (t
       (alert
         (strcat "El objeto "
           nombre
           " seleccionado\ntiene un Área de "
           (rtos (vlax-curve-GetArea obj))
           " unidades."))))))
;;;Listado 15.7. Determinación del Área encerrada por la curva.

(defun ent-rayo  (pt vector)
  (entmake (list '(0 . "RAY")
                 '(100 . "AcDbEntity")
                 '(100 . "AcDbRay")
                 (cons 10 pt)
                 (cons 11 vector))))
;;;Listado 15.8. Función para dibujar un RAYO.

(defun calc-tangente (ename-curva pt / dir objCurva param)
  (setq dir (trans (getvar "viewdir"1 0 t)
        pt  (trans pt 1 0))
  (if (and (setq objCurva (vlax-ename->vla-object ename-curva))
           (setq pt (vl-catch-all-apply
                    'vlax-curve-GetClosestPointToProjection
                    (list objCurva pt dir))))
    (if (vl-catch-all-error-p pt)
      nil
      (progn (setq param (vlax-curve-GetParamAtPoint objCurva pt))
             (list pt (vlax-curve-GetFirstDeriv objCurva param))))))
;;;Listado 15.9. Función que calcula la tangente a una curva.

(defun C:TANGENTE  (/ seleccion datos)
  (cmd-entrar)
  (if (setq seleccion (entsel "\nDesigne punto de tangencia: "))
    (if (setq datos (calc-tangente (car seleccion) (cadr seleccion)))
      (ent-rayo (car datos) (cadr datos))
      (prompt "\nError en la operación.")))
  (cmd-salir)
  (princ))
;;;Listado 15.10. Comando para dibujar un RAYO tangente a una curva.

(defun cmd-vectorz  (pt vector /)
  (setvar "CMDECHO" 0)
  (vl-cmdf "._ucs"
           "_zaxis"
           "_none"
           (trans pt 0 1)
           "_none"
           (trans (mapcar '+ pt vector) 0 1))
  (setvar "CMDECHO" 1))
;;;Listado 15.11. Función para establecer un sistema de coordenadas a partir de un punto y un vector.

(defun ax-scp-normal (origen vec-z / ang vec-x vec-y)
  (setq ang   (- (angle '(0 0 0) vec-z) (/ pi 2))
        vec-X (vec '(0 0 0) (polar '(0 0 0) ang 1.0))
        vec-Y (prod-vec vec-z vec-x))
  (vla-put-ActiveUCS
    *aevl:dibujo*
    (ax-scp "TMP" origen vec-x vec-y)))
;;;Listado 15.12. SCP mediante ActiveX a partir del vector de dirección del eje Z.

(defun ax-MTrans (origen vec-z / ang vec-x vec-y)
  (setq ang   (- (angle '(0 0 0) vec-z) (/ pi 2))
        vec-X (vec '(0 0 0) (polar '(0 0 0) ang 1.0))
        vec-Y (prod-vec vec-z vec-x))
  (vla-GetUCSMatrix (ax-scp "TMP" origen vec-x vec-y)))
;;;Listado 15.13. Función que devuelve la matriz de transformación de un SCP.

(defun C:SCP-NORMAL  (/ seleccion datos)
  (if (setq seleccion (entsel "\nDesigne origen sobre una curva: "))
    (if (setq datos (calc-tangente (car seleccion) (cadr seleccion)))
      (ax-scp-normal (car datos) (cadr datos))
      (prompt "\nError en la operación.")))
  (princ))
;;;Listado 15.14. Comando que establece un SCP perpendicular a una curva.

(defun ax-gradua  (obj dist / long avance tmp)
  (setq long   (ax-longcurva obj)
        avance dist)
  (while (<= avance long)
    (setq tmp    (cons (vlax-curve-GetPointAtDist obj avance) tmp)
          avance (+ avance dist)))
  (reverse tmp))
;;;Listado 15.15. Calcular puntos a distancias fijas.

(defun C:PARTE-DIST (/ sset ent obj dist puntos)
  (vla-StartUndoMark *aevl:dibujo*)
  (prompt "\nDesigne curva a partir: ")
  (while
    (not (and (setq sset (ssget "_:S" '((0 . "*LINE,ARC,HELIX"))))
              (not (vlax-curve-isClosed (ssname sset 0)))))
     (prompt "\nDesigne una curva abierta: "))
  (setq ent (ssname sset 0)
        obj (vlax-ename->vla-object ent))
  (initget (+ 1 2 4 128"Distancia")
  (setq dist (getint "\nNúmero de segmentos o [Distancia]:"))
  (cond ((= (type dist) 'STR)
         (initget (+ 1 2 4))
         (setq dist (getreal "\nLongitud de segmento:")))
        (t
         (setq dist (/ (vlax-curve-GetDistAtParam
                     obj
                     (vlax-curve-GetEndParam obj))
                   dist))))
  (setq puntos (ax-gradua obj dist))
  (cmd-entrar)
  (foreach pt  puntos
    (vl-cmdf "_BREAK"
             (list ent (trans pt 0 1))
             "_F"
             (trans pt 0 1)
             "@")
    (setq ent (entlast)))
  (cmd-salir)
  (vla-EndUndoMark *aevl:dibujo*))
;;;Listado 15.16. Partir una entidad en segmentos iguales.

(defun coord->puntos  (lst ext / i puntos)
  (setq i 0)
  (while (< i ext)
    (setq puntos (cons (list (nth (- ext (+ i 2)) lst)
                       (nth (- ext (+ i 1)) lst)
                       (nth (- ext i) lst))
                   puntos)
          i      (+ i 3)))
  puntos)
;;;Listado 15.17. Creación de una lista de puntos a partir de una lista de coordenadas.

(defun modo-ext  (modo)
  (cond ((null modo) acExtendNone)
        ((eq modo TacExtendBoth)
        (t modo)))
;;;Listado 15.18. Determinación del modo de extender las entidades.

(defun intersecciones  (obj1 obj2 modo / cruces limite pti)
  (setq cruces (vl-catch-all-apply
                 'vla-IntersectWith
                 (list (vlax-ename->vla-object obj1)
                       (vlax-ename->vla-object obj2)
                       (modo-ext modo))))
  (if (not (vl-catch-all-error-p cruces))
    (progn
      (setq pti (vlax-variant-value cruces))
      (if (< (setq limite (vlax-safearray-get-u-bound pti 1)) 0)
         nil
         (coord->puntos (vlax-safearray->list pti) limite)))))
;;;Listado 15.19. Función INTERSECCIONES.