Espacio de dudas y consultas sobre Visual Lisp y Autolisp para personalización en AutoCAD

[joaquim.moral]

Buenas a todos y a todas,

de la mano del Expert Elite @calderg1000, abrimos este espacio para la resolución de dudas y consultas relacionadas con LISP para AutoCAD.

Os animamos a que planteéis aquí vuestras preguntas al experto, así como también creéis preguntas nuevas en el foro de AutoCAD incluyendo "Visual Lisp, Autolisp, o LISP" al inicio o al final del título de la pregunta para que identificarlas sea más fácil para la Comunidad.

Hasta pronto,

[calderg1000]

Estimado @joaquim.moral 

Muy agradecido por la confianza, para colaborar en este nuevo espacio. Y animamos a toda la comunidad en Español, hacer sus consultas y contribuciones sobre este apasiónate tema de la programación en Autolisp y visual lisp para personalizar y potencializar enormemente sus flujos de trabajo en AutoCAD, C3D y otros afines.

Aqui estaremos con mucho gusto para colaborar con esta gran comunidad.

Saludos.

[citarq77victor]

(defun angle-between-points (p1 p2)
;; Calcula el ángulo en radianes entre dos puntos respecto al origen (0,0)
(atan (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))
)

(defun get-polygon-center (entidad)
;; Calcula el centroide de un polígono cerrado (LWPOLYLINE)
(setq coords (mapcar 'cdr (vl-remove-if-not
(lambda (x) (= (car x) 10))
(entget entidad))))
(setq sum-x 0.0 sum-y 0.0)
(foreach pt coords
(setq sum-x (+ sum-x (car pt)))
(setq sum-y (+ sum-y (cadr pt))))
(list (/ sum-x (length coords)) (/ sum-y (length coords)))
)

(defun c:AnotarLotes (/ sel-lotes manzano num-lotes poligonos poligono-inicial centroide-inicial poligono-entidad area)
;; Solicitar la selección de lotes (polígonos cerrados)
(setq sel-lotes (ssget '((0 . "LWPOLYLINE") (70 . 1)))) ; Solo polilíneas cerradas

;; Validar si se seleccionaron lotes
(if sel-lotes
(progn
;; Solicitar el polígono inicial
(princ "\nSelecciona un polígono de inicio para el recorrido.")
(setq poligono-inicial (car (entsel "\nSeleccione el polígono de inicio: ")))

;; Validar si se seleccionó un polígono inicial
(if (not poligono-inicial)
(progn
(princ "\nNo se seleccionó un polígono de inicio.")
(exit)
)
)

;; Calcular el centroide del polígono inicial
(setq centroide-inicial (get-polygon-center poligono-inicial))

;; Solicitar el número de manzano
(setq manzano (getstring T "\nIntroduce el número del manzano (ejemplo: 1): "))

;; Validar que el número de manzano no sea vacío
(if (not manzano)
(progn
(princ "\nError: El número del manzano no puede estar vacío.")
(exit)
)
)

;; Inicializar el contador de lotes
(setq num-lotes 1)

;; Inicializar lista de polígonos y calcular sus centroides
(setq poligonos '())
(repeat (sslength sel-lotes)
(setq poligono-entidad (ssname sel-lotes (1- (sslength sel-lotes))))
(setq poligonos (cons (get-polygon-center poligono-entidad) poligonos))
)

;; Ordenar los polígonos en sentido horario con base en el centroide inicial
(setq poligonos (vl-sort poligonos
(function (lambda (p1 p2)
(< (angle-between-points centroide-inicial p1)
(angle-between-points centroide-inicial p2))))))

;; Anotar cada polígono
(foreach centroide poligonos
(setq poligono-entidad (car (entsel "\nSeleccione un polígono para anotar: ")))
;; Calcular el área del polígono
(setq area (vlax-curve-getarea poligono-entidad))

;; Crear las posiciones del texto
(setq texto-lote (list (car centroide) (+ (cadr centroide) 1))) ; Lote arriba
(setq texto-mzna (list (car centroide) (cadr centroide))) ; Mzna al centro
(setq texto-superficie (list (car centroide) (- (cadr centroide) 1))) ; Superficie abajo

;; Crear las anotaciones
(command "TEXT" "J" "M" texto-lote 1 0 (strcat "Lote: " (itoa num-lotes)))
(command "TEXT" "J" "M" texto-mzna 1 0 (strcat "Mzna: " manzano))
(command "TEXT" "J" "M" texto-superficie 1 0 (strcat "Superficie: " (rtos area 2 2) " m²"))

;; Incrementar el contador de lotes
(setq num-lotes (1+ num-lotes))
)
(princ "\nAnotación de lotes completada.")
)
;; Si no se seleccionan lotes, mostrar mensaje de error
(princ "\nNo se seleccionaron lotes.")
)
(princ)
)

me sale este error (Seleccione el polígono de inicio: ; error: bad function: #<SUBR @00000160e8823660 -lambda->)

[calderg1000]

Saludos @citarq77victor 

Además del error que mencionas, veo que tienes otros mas por resolver. Pero es solo cuestión de forma.

En cuanto al error de tu consulta. lo puedes arreglar anteponiendo un apostrofe a la función Lambda. aquí te muestro:

Por el momento ya esta funcionando. Pero todavía al parecer el reporte de datos de los polígonos, no se están insertando en el centroide de cada uno.

Muéstranos un DWG donde vas aplicar la rutina. Para poder hacer las pruebas.

(defun get-polygon-center (entidad)
;; Calcula el centroide de un polígono cerrado (LWPOLYLINE)
(setq coords (mapcar 'cdr (vl-remove-if-not
'(lambda (x) (= (car x) 10));;;aqui le puse el apostrofe...
(entget entidad))))
(setq sum-x 0.0 sum-y 0.0)
(foreach pt coords
(setq sum-x (+ sum-x (car pt)))
(setq sum-y (+ sum-y (cadr pt))))
(list (/ sum-x (length coords)) (/ sum-y (length coords)))
)

[calderg1000]

Saludos @citarq77victor 

Aquí te adjunto una rutina en Autolisp que programe para aplicar a tu consulta. Espero que te pueda ser de utilidad...

Cualquier consulta sobre la rutina, con mucho gusto estaremos por aquí para responder...

;;;By [email protected], 01-02-25
;;;elevZ: Eleva las polilinea y lineas que representan curvas de nivel que se encuentran con elevacion=0
;;;___
(defun c:elevZ (/ sn tx h coord p1 p2 sln)
  (setq
    sn (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "*text"))))))
  )
  (foreach j sn
    (if (= (cdr (assoc 0 (entget j))) "MTEXT")
      (vla-put-attachmentpoint (vlax-ename->vla-object j) 7)
    )
    (setq tx    (atof (cdr (assoc 1 (entget j))))
          h     (cdr (assoc 40 (entget j)))
          coord (cdr (assoc 10 (entget j)))
          p1    (vlax-get (vlax-ename->vla-object j) 'insertionpoint)
          p2    (polar p1 (* pi 0.5) h)
          sln   (entget (ssname (ssget "_f" (list p1 p2) '((0 . "lwpolyline"))) 0))
    )
    (entmod (subst (cons 10 (list (car coord) (cadr coord) tx))
                   (assoc 10 (entget j))
                   (entget j)
            )
    )
    (entmod (subst (cons 38 tx) (assoc 38 sln) sln))
  )
  (princ)
)