;;;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 T) acExtendBoth)
(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.
