help to improve lisp routine, (coordinate grid)

Tuesday at 03:36 PM

Hello everyone.
I need to improve a Lisp routine. I've had this routine for a few years; a coworker gave it to me.
It's a Lisp routine for generating a coordinate grid from a selection of three points.
I need to eliminate the insertion of three points (vertices). I want to be able to select a closed polyline with a single click and generate the grid.
I want to keep the entire structure of the Lisp; I only want to change the vertex selection.
I should mention that I have no experience programming AutoLISP.
Please, if you can help me with this.

(defun strpto (aa / largo)
	(setq largo (strlen aa))
	(cond ((< largo 4) aa)
		((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
		((= largo 7) (strcat (substr aa 1 1) "." (substr aa 2 3) "." (substr aa 5 3)))
		(t aa)
	)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
   (setq a1 (- (cadr p2)(cadr p1))
         a2 (- (cadr p4)(cadr p2))
         a3 (- (cadr p3)(cadr p4))
         a4 (- (cadr p1)(cadr p3))
         b1 (- (car p1)(car p2))
         b2 (- (car p2)(car p4))
         b3 (- (car p4)(car p3))
         b4 (- (car p3)(car p1))
         c1 (- (* (car p1)(cadr p2))(* (car p2)(cadr p1)))
         c2 (- (* (car p2)(cadr p4))(* (car p4)(cadr p2)))
         c3 (- (* (car p4)(cadr p3))(* (car p3)(cadr p4)))
         c4 (- (* (car p3)(cadr p1))(* (car p1)(cadr p3)))
   )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX (a b c y)
   (if (= 0.0 a)            ; no hay interseccion
       nil
       (/ (- c (* b y)) a)
   )
)

(Defun IntersecX ( / l lista)
   (setq l ()
         lista (list (CalculaX a1 b1 c1 startY) (CalculaX a2 b2 c2 startY)
                     (CalculaX a3 b3 c3 startY) (CalculaX a4 b4 c4 startY)
               )
   )
   (while (/= lista nil)
       (setq x (car lista))
       (if (and (/= x nil) (<= x maxX) (>= x minX))
           (setq l (append l (list x)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY (a b c x)
   (if (= 0.0 b)                 ; no hay interseccion
       nil
       (/ (- c (* a x)) b)
   )
)

(Defun IntersecY ( / l lista)
   (setq l ()
         lista (list (CalculaY a1 b1 c1 startX) (CalculaY a2 b2 c2 startX)
                     (CalculaY a3 b3 c3 startX) (CalculaY a4 b4 c4 startX)
               )
   )
   (while (/= lista nil)
       (setq y (car lista))
       (if (and (/= y nil) (<= y maxY) (>= y minY))
           (setq l (append l (list y)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla (/ p1 p2 p3 p4 paux incx incy l h n maldato base
                   alfa startX startY minX minY maxX maxY)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
  (setq p1 (getpoint "\nIngrese un vertice de la region ")
        p2 (getpoint p1 "\nIngrese el otro vertice ")
  )
  (command "LINE" p1 p2 "")
  (if (> (cadr p1)(cadr p2))              ; siempre el p1 abajo
      (setq paux p1 p1 p2 p2 paux)
  )
  (setq p3 (getpoint p1 "\nIngrese punto para Ancho de la region ")
        l (distance p1 p3)        ; calculo de puntos p3 y p4 , paralelos
        alfa (angle p1 p2)        ; a p1 y p2 a distancia l
        alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
         (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
      (if (< (* (- (car p2)(car p1)) (- (cadr p3)(cadr p1))) 0.0)
          (setq alfa (+ pi alfa))
      )
  )
  (setq p3 (list (+ (car p1)(* l (cos alfa))) (+ (cadr p1)(* l (sin alfa))))
        p4 (list (+ (car p2)(* l (cos alfa))) (+ (cadr p2)(* l (sin alfa))))
  )
  (command "LINE" p1 p2 p4 p3 "C")                 ; marco exterior
  (if (< (cadr p3) (cadr p1))                      ; punto1 siempre mas bajo
      (setq  paux p1 p1 p3 p3 paux paux p2 p2 p4 p4 paux)
  )
  (setq minX (min (car p2) (car p3))
        maxX (max (car p2) (car p3))
        minY (cadr p1)
        maxY (cadr p4)
        l (- maxX minX)
        h (- maxY minY)
        malDato 1
  )
  (while (= malDato 1)
         (setq incx (getreal "\nIncremento malla (m) :"))
         (if (< (abs (/ l 3)) incrx)
             (print "\nIncremento muy grande")
             (setq malDato 0)
         )
  )

  (setq incy incx)

  (setq n (fix (/ minX incx))             ; posiciones donde comenzar
        startX (* (1+ n) incx)            ; el cuadriculado
        n (fix (/ minY incy))             ; tanto en X como en Y
        startY (* (1+ n) incy)
        largoMax (max (distance p1 p3)    ; el largo maximo de la region
                      (distance p1 p4)
                 )
  )
  (if (< minX 0)
      (setq startX (- startX incx))
  )
  (if (< minY 0)
      (setq startY (- startY incy))
  )

  (setq ff     (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala)) ; alto de los caracteres

  (setq angP1P3 (angle p1 p3)
        angP1P2 (angle p1 p2)
        angBorde (min (abs angP1P3)(abs angP1P2))
        dh (min (/ incx 40.0)(/ incy 40.0))
        x1 minX              ; el caso en que no hay que rotar
        x2 maxX
        y1 minY
        y2 maxY
  )
  (if (or (= (cadr p1)(cadr p2)) (= (car p1)(car p3)) (= (car p1)(car p2)))
      (setq revisar 0
            dl (min (/ incx 30.0)(/ incy 30.0))
      )
      (setq revisar 1
            dl (* (* alto (/ (cos angBorde)(sin angBorde))) 2)
      )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
         (if (= revisar 1)
            (setq ptos (IntersecX)
                  x1 (car ptos)
                  x2 (cadr ptos)
            )
         )
         (setq coordY (rtos startY 2 0)
               coordY (strcat "N-" (strpto coordY))
         )
         (command "LINE" (list x1 startY) (list x2 startY) "")
         (cond ((> (- maxY startY) (* 2 alto))
                (command "TEXT" (list (+ x1 dl) (+ startY dh)) alto 0 coordY)
                (command "TEXT" "R" (list (- x2 dl) (+ startY dh)) alto 0 coordY)
               )
         )
         (setq startY (+ startY incy))
  )
  (while (< startX maxX)
         (if (= revisar 1)
             (setq ptos (IntersecY)
                   y1 (car ptos)
                   y2 (cadr ptos)
             )

         )
         (setq coordX (rtos startX 2 0)
               coordX (strcat "E-" (strpto coordX))
         )
         (command "LINE" (list startX y1) (list startX y2) "")
         (cond ((> (- startX minX) (* 2 alto))
                (command "TEXT" (list (- startX dh) (+ y1 dl)) alto 100 coordX)
                (command "TEXT" "R" (list (- startX dh) (- y2 dl)) alto 100 coordX)
               )
         )
         (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
      (setq alfa angP1P3)
      (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
      (setq alfarad (* -1 alfa)
            alfa (* -1 (/ (* 200 alfa) pi))
            p4 (list (- (* (car p4)(cos alfarad)) (* (cadr p4) (sin alfarad)))
                     (+ (* (car p4)(sin alfarad)) (* (cadr p4) (cos alfarad)))
               )
            p1 (list (- (* (car p1)(cos alfarad)) (* (cadr p1)(sin alfarad)))
                     (+ (* (car p1)(sin alfarad)) (* (cadr p1)(cos alfarad)))
               )
            base (list 0.0 0.0)   ; el origen
       )
  )
    (command "_.undo" "end")
    (command "_.undo" "auto" "on")
;;  (command "units" "2" "3" "3" "4" "n" "y")
)

Tuesday at 09:58 PM

6 hours ago, Omar ugarte said:

Hello everyone.
I need to improve a Lisp routine. I've had this routine for a few years; a coworker gave it to me.
It's a Lisp routine for generating a coordinate grid from a selection of three points.
I need to eliminate the insertion of three points (vertices). I want to be able to select a closed polyline with a single click and generate the grid.
I want to keep the entire structure of the Lisp; I only want to change the vertex selection.
I should mention that I have no experience programming AutoLISP.
Please, if you can help me with this.

(defun strpto (aa / largo)
	(setq largo (strlen aa))
	(cond ((< largo 4) aa)
		((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
		((= largo 7) (strcat (substr aa 1 1) "." (substr aa 2 3) "." (substr aa 5 3)))
		(t aa)
	)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
   (setq a1 (- (cadr p2)(cadr p1))
         a2 (- (cadr p4)(cadr p2))
         a3 (- (cadr p3)(cadr p4))
         a4 (- (cadr p1)(cadr p3))
         b1 (- (car p1)(car p2))
         b2 (- (car p2)(car p4))
         b3 (- (car p4)(car p3))
         b4 (- (car p3)(car p1))
         c1 (- (* (car p1)(cadr p2))(* (car p2)(cadr p1)))
         c2 (- (* (car p2)(cadr p4))(* (car p4)(cadr p2)))
         c3 (- (* (car p4)(cadr p3))(* (car p3)(cadr p4)))
         c4 (- (* (car p3)(cadr p1))(* (car p1)(cadr p3)))
   )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX (a b c y)
   (if (= 0.0 a)            ; no hay interseccion
       nil
       (/ (- c (* b y)) a)
   )
)

(Defun IntersecX ( / l lista)
   (setq l ()
         lista (list (CalculaX a1 b1 c1 startY) (CalculaX a2 b2 c2 startY)
                     (CalculaX a3 b3 c3 startY) (CalculaX a4 b4 c4 startY)
               )
   )
   (while (/= lista nil)
       (setq x (car lista))
       (if (and (/= x nil) (<= x maxX) (>= x minX))
           (setq l (append l (list x)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY (a b c x)
   (if (= 0.0 b)                 ; no hay interseccion
       nil
       (/ (- c (* a x)) b)
   )
)

(Defun IntersecY ( / l lista)
   (setq l ()
         lista (list (CalculaY a1 b1 c1 startX) (CalculaY a2 b2 c2 startX)
                     (CalculaY a3 b3 c3 startX) (CalculaY a4 b4 c4 startX)
               )
   )
   (while (/= lista nil)
       (setq y (car lista))
       (if (and (/= y nil) (<= y maxY) (>= y minY))
           (setq l (append l (list y)))
       )
       (setq lista (cdr lista))
   )
   (list (min (car l)(cadr l)) (max (car l)(cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla (/ p1 p2 p3 p4 paux incx incy l h n maldato base
                   alfa startX startY minX minY maxX maxY)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
  (setq p1 (getpoint "\nIngrese un vertice de la region ")
        p2 (getpoint p1 "\nIngrese el otro vertice ")
  )
  (command "LINE" p1 p2 "")
  (if (> (cadr p1)(cadr p2))              ; siempre el p1 abajo
      (setq paux p1 p1 p2 p2 paux)
  )
  (setq p3 (getpoint p1 "\nIngrese punto para Ancho de la region ")
        l (distance p1 p3)        ; calculo de puntos p3 y p4 , paralelos
        alfa (angle p1 p2)        ; a p1 y p2 a distancia l
        alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
         (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
      (if (< (* (- (car p2)(car p1)) (- (cadr p3)(cadr p1))) 0.0)
          (setq alfa (+ pi alfa))
      )
  )
  (setq p3 (list (+ (car p1)(* l (cos alfa))) (+ (cadr p1)(* l (sin alfa))))
        p4 (list (+ (car p2)(* l (cos alfa))) (+ (cadr p2)(* l (sin alfa))))
  )
  (command "LINE" p1 p2 p4 p3 "C")                 ; marco exterior
  (if (< (cadr p3) (cadr p1))                      ; punto1 siempre mas bajo
      (setq  paux p1 p1 p3 p3 paux paux p2 p2 p4 p4 paux)
  )
  (setq minX (min (car p2) (car p3))
        maxX (max (car p2) (car p3))
        minY (cadr p1)
        maxY (cadr p4)
        l (- maxX minX)
        h (- maxY minY)
        malDato 1
  )
  (while (= malDato 1)
         (setq incx (getreal "\nIncremento malla (m) :"))
         (if (< (abs (/ l 3)) incrx)
             (print "\nIncremento muy grande")
             (setq malDato 0)
         )
  )

  (setq incy incx)

  (setq n (fix (/ minX incx))             ; posiciones donde comenzar
        startX (* (1+ n) incx)            ; el cuadriculado
        n (fix (/ minY incy))             ; tanto en X como en Y
        startY (* (1+ n) incy)
        largoMax (max (distance p1 p3)    ; el largo maximo de la region
                      (distance p1 p4)
                 )
  )
  (if (< minX 0)
      (setq startX (- startX incx))
  )
  (if (< minY 0)
      (setq startY (- startY incy))
  )

  (setq ff     (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala)) ; alto de los caracteres

  (setq angP1P3 (angle p1 p3)
        angP1P2 (angle p1 p2)
        angBorde (min (abs angP1P3)(abs angP1P2))
        dh (min (/ incx 40.0)(/ incy 40.0))
        x1 minX              ; el caso en que no hay que rotar
        x2 maxX
        y1 minY
        y2 maxY
  )
  (if (or (= (cadr p1)(cadr p2)) (= (car p1)(car p3)) (= (car p1)(car p2)))
      (setq revisar 0
            dl (min (/ incx 30.0)(/ incy 30.0))
      )
      (setq revisar 1
            dl (* (* alto (/ (cos angBorde)(sin angBorde))) 2)
      )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
         (if (= revisar 1)
            (setq ptos (IntersecX)
                  x1 (car ptos)
                  x2 (cadr ptos)
            )
         )
         (setq coordY (rtos startY 2 0)
               coordY (strcat "N-" (strpto coordY))
         )
         (command "LINE" (list x1 startY) (list x2 startY) "")
         (cond ((> (- maxY startY) (* 2 alto))
                (command "TEXT" (list (+ x1 dl) (+ startY dh)) alto 0 coordY)
                (command "TEXT" "R" (list (- x2 dl) (+ startY dh)) alto 0 coordY)
               )
         )
         (setq startY (+ startY incy))
  )
  (while (< startX maxX)
         (if (= revisar 1)
             (setq ptos (IntersecY)
                   y1 (car ptos)
                   y2 (cadr ptos)
             )

         )
         (setq coordX (rtos startX 2 0)
               coordX (strcat "E-" (strpto coordX))
         )
         (command "LINE" (list startX y1) (list startX y2) "")
         (cond ((> (- startX minX) (* 2 alto))
                (command "TEXT" (list (- startX dh) (+ y1 dl)) alto 100 coordX)
                (command "TEXT" "R" (list (- startX dh) (- y2 dl)) alto 100 coordX)
               )
         )
         (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
      (setq alfa angP1P3)
      (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
      (setq alfarad (* -1 alfa)
            alfa (* -1 (/ (* 200 alfa) pi))
            p4 (list (- (* (car p4)(cos alfarad)) (* (cadr p4) (sin alfarad)))
                     (+ (* (car p4)(sin alfarad)) (* (cadr p4) (cos alfarad)))
               )
            p1 (list (- (* (car p1)(cos alfarad)) (* (cadr p1)(sin alfarad)))
                     (+ (* (car p1)(sin alfarad)) (* (cadr p1)(cos alfarad)))
               )
            base (list 0.0 0.0)   ; el origen
       )
  )
    (command "_.undo" "end")
    (command "_.undo" "auto" "on")
;;  (command "units" "2" "3" "3" "4" "n" "y")
)

Hi Omar. Bienvenido

Try this

(defun strpto (aa / largo)
  (setq largo (strlen aa))
  (cond	((< largo 4) aa)
	((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
	((= largo 7)
	 (strcat (substr aa 1 1)
		 "."
		 (substr aa 2 3)
		 "."
		 (substr aa 5 3)
	 )
	)
	(t aa)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
  (setq	a1 (- (cadr p2) (cadr p1))
	a2 (- (cadr p4) (cadr p2))
	a3 (- (cadr p3) (cadr p4))
	a4 (- (cadr p1) (cadr p3))
	b1 (- (car p1) (car p2))
	b2 (- (car p2) (car p4))
	b3 (- (car p4) (car p3))
	b4 (- (car p3) (car p1))
	c1 (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
	c2 (- (* (car p2) (cadr p4)) (* (car p4) (cadr p2)))
	c3 (- (* (car p4) (cadr p3)) (* (car p3) (cadr p4)))
	c4 (- (* (car p3) (cadr p1)) (* (car p1) (cadr p3)))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX	(a b c y)
  (if (= 0.0 a)				; no hay interseccion
    nil
    (/ (- c (* b y)) a)
  )
)

(Defun IntersecX (/ l lista)
  (setq	l     ()
	lista (list (CalculaX a1 b1 c1 startY)
		    (CalculaX a2 b2 c2 startY)
		    (CalculaX a3 b3 c3 startY)
		    (CalculaX a4 b4 c4 startY)
	      )
  )
  (while (/= lista nil)
    (setq x (car lista))
    (if	(and (/= x nil) (<= x maxX) (>= x minX))
      (setq l (append l (list x)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY	(a b c x)
  (if (= 0.0 b)				; no hay interseccion
    nil
    (/ (- c (* a x)) b)
  )
)

(Defun IntersecY (/ l lista)
  (setq	l     ()
	lista (list (CalculaY a1 b1 c1 startX)
		    (CalculaY a2 b2 c2 startX)
		    (CalculaY a3 b3 c3 startX)
		    (CalculaY a4 b4 c4 startX)
	      )
  )
  (while (/= lista nil)
    (setq y (car lista))
    (if	(and (/= y nil) (<= y maxY) (>= y minY))
      (setq l (append l (list y)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)

(defun dameEsquinas (e / le lp)
  (if (= (cdr (assoc 0 (setq le (entget e)))) "LWPOLYLINE")
    (foreach l le
      (if (= (car l) 10)
	(setq lp (cons (cdr l) lp))
      )
    )
  )
  (if lp (vl-sort lp '(lambda(a b) (< (car a) (car b)))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla	(/	p1     p2     p3     p4	    paux   incx
		 incy	l      h      n	     maldato	   base
		 alfa	startX startY minX   minY   maxX   maxY
		)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
;;;  (setq	p1 (getpoint "\nIngrese un vertice de la region ")
;;;	p2 (getpoint p1 "\nIngrese el otro vertice ")
;;;  )
;;;  (command "LINE" p1 p2 "")
  (if (not (setq e (car (entsel "\nSelecciona el marco para la grilla..."))))
    (exit)
  )
  (setq l (dameEsquinas e)
	p1 (car l)
	p2 (cadr l)
	p3 (caddr l)
	l nil
  )
  (if (> (cadr p1) (cadr p2))		; siempre el p1 abajo
    (setq paux p1
	  p1 p2
	  p2 paux
    )
  )
  (setq	p3   (getpoint p1 "\nIngrese punto para Ancho de la region ")
	l    (distance p1 p3)		; calculo de puntos p3 y p4 , paralelos
	alfa (angle p1 p2)		; a p1 y p2 a distancia l
	alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
    (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
    (if	(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 0.0)
      (setq alfa (+ pi alfa))
    )
  )
  (setq	p3 (list (+ (car p1) (* l (cos alfa)))
		 (+ (cadr p1) (* l (sin alfa)))
	   )
	p4 (list (+ (car p2) (* l (cos alfa)))
		 (+ (cadr p2) (* l (sin alfa)))
	   )
  )
  (command "LINE" p1 p2 p4 p3 "C")	; marco exterior
  (if (< (cadr p3) (cadr p1))		; punto1 siempre mas bajo
    (setq paux p1
	  p1 p3
	  p3 paux
	  paux p2
	  p2 p4
	  p4 paux
    )
  )
  (setq	minX	(min (car p2) (car p3))
	maxX	(max (car p2) (car p3))
	minY	(cadr p1)
	maxY	(cadr p4)
	l	(- maxX minX)
	h	(- maxY minY)
	malDato	1
  )
  (while (= malDato 1)
    (setq incx (getreal "\nIncremento malla (m) :"))
    (if	(< (abs (/ l 3)) incrx)
      (print "\nIncremento muy grande")
      (setq malDato 0)
    )
  )

  (setq incy incx)

  (setq	n	 (fix (/ minX incx))	; posiciones donde comenzar
	startX	 (* (1+ n) incx)	; el cuadriculado
	n	 (fix (/ minY incy))	; tanto en X como en Y
	startY	 (* (1+ n) incy)
	largoMax (max (distance p1 p3)	; el largo maximo de la region
		      (distance p1 p4)
		 )
  )
  (if (< minX 0)
    (setq startX (- startX incx))
  )
  (if (< minY 0)
    (setq startY (- startY incy))
  )

  (setq ff (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala))	; alto de los caracteres

  (setq	angP1P3	 (angle p1 p3)
	angP1P2	 (angle p1 p2)
	angBorde (min (abs angP1P3) (abs angP1P2))
	dh	 (min (/ incx 40.0) (/ incy 40.0))
	x1	 minX			; el caso en que no hay que rotar
	x2	 maxX
	y1	 minY
	y2	 maxY
  )
  (if (or (= (cadr p1) (cadr p2))
	  (= (car p1) (car p3))
	  (= (car p1) (car p2))
      )
    (setq revisar 0
	  dl	  (min (/ incx 30.0) (/ incy 30.0))
    )
    (setq revisar 1
	  dl	  (* (* alto (/ (cos angBorde) (sin angBorde))) 2)
    )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
    (if	(= revisar 1)
      (setq ptos (IntersecX)
	    x1	 (car ptos)
	    x2	 (cadr ptos)
      )
    )
    (setq coordY (rtos startY 2 0)
	  coordY (strcat "N-" (strpto coordY))
    )
    (command "LINE" (list x1 startY) (list x2 startY) "")
    (cond ((> (- maxY startY) (* 2 alto))
	   (command "TEXT"
		    (list (+ x1 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	   (command "TEXT"
		    "R"
		    (list (- x2 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	  )
    )
    (setq startY (+ startY incy))
  )
  (while (< startX maxX)
    (if	(= revisar 1)
      (setq ptos (IntersecY)
	    y1	 (car ptos)
	    y2	 (cadr ptos)
      )

    )
    (setq coordX (rtos startX 2 0)
	  coordX (strcat "E-" (strpto coordX))
    )
    (command "LINE" (list startX y1) (list startX y2) "")
    (cond ((> (- startX minX) (* 2 alto))
	   (command "TEXT"
		    (list (- startX dh) (+ y1 dl))
		    alto
		    100
		    coordX
	   )
	   (command "TEXT"
		    "R"
		    (list (- startX dh) (- y2 dl))
		    alto
		    100
		    coordX
	   )
	  )
    )
    (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
    (setq alfa angP1P3)
    (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
    (setq alfarad (* -1 alfa)
	  alfa	  (* -1 (/ (* 200 alfa) pi))
	  p4	  (list	(- (* (car p4) (cos alfarad)) (* (cadr p4) (sin alfarad)))
			(+ (* (car p4) (sin alfarad)) (* (cadr p4) (cos alfarad)))
		  )
	  p1	  (list	(- (* (car p1) (cos alfarad)) (* (cadr p1) (sin alfarad)))
			(+ (* (car p1) (sin alfarad)) (* (cadr p1) (cos alfarad)))
		  )
	  base	  (list 0.0 0.0)	; el origen
    )
  )
  (command "_.undo" "end")
  (command "_.undo" "auto" "on")
  ;;  (command "units" "2" "3" "3" "4" "n" "y")
)

The "command" calls in your code are designed for an English version of AutoCAD, and mine is in Spanish.
For this reason, and due to lack of time, I haven't tested the code sufficiently.

Try it yourself and then comment on the results.

Tuesday at 11:26 PM

1 hour ago, GLAVCVS said:

Hi Omar. Bienvenido

Try this

(defun strpto (aa / largo)
  (setq largo (strlen aa))
  (cond	((< largo 4) aa)
	((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
	((= largo 7)
	 (strcat (substr aa 1 1)
		 "."
		 (substr aa 2 3)
		 "."
		 (substr aa 5 3)
	 )
	)
	(t aa)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
  (setq	a1 (- (cadr p2) (cadr p1))
	a2 (- (cadr p4) (cadr p2))
	a3 (- (cadr p3) (cadr p4))
	a4 (- (cadr p1) (cadr p3))
	b1 (- (car p1) (car p2))
	b2 (- (car p2) (car p4))
	b3 (- (car p4) (car p3))
	b4 (- (car p3) (car p1))
	c1 (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
	c2 (- (* (car p2) (cadr p4)) (* (car p4) (cadr p2)))
	c3 (- (* (car p4) (cadr p3)) (* (car p3) (cadr p4)))
	c4 (- (* (car p3) (cadr p1)) (* (car p1) (cadr p3)))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX	(a b c y)
  (if (= 0.0 a)				; no hay interseccion
    nil
    (/ (- c (* b y)) a)
  )
)

(Defun IntersecX (/ l lista)
  (setq	l     ()
	lista (list (CalculaX a1 b1 c1 startY)
		    (CalculaX a2 b2 c2 startY)
		    (CalculaX a3 b3 c3 startY)
		    (CalculaX a4 b4 c4 startY)
	      )
  )
  (while (/= lista nil)
    (setq x (car lista))
    (if	(and (/= x nil) (<= x maxX) (>= x minX))
      (setq l (append l (list x)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY	(a b c x)
  (if (= 0.0 b)				; no hay interseccion
    nil
    (/ (- c (* a x)) b)
  )
)

(Defun IntersecY (/ l lista)
  (setq	l     ()
	lista (list (CalculaY a1 b1 c1 startX)
		    (CalculaY a2 b2 c2 startX)
		    (CalculaY a3 b3 c3 startX)
		    (CalculaY a4 b4 c4 startX)
	      )
  )
  (while (/= lista nil)
    (setq y (car lista))
    (if	(and (/= y nil) (<= y maxY) (>= y minY))
      (setq l (append l (list y)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)

(defun dameEsquinas (e / le lp)
  (if (= (cdr (assoc 0 (setq le (entget e)))) "LWPOLYLINE")
    (foreach l le
      (if (= (car l) 10)
	(setq lp (cons (cdr l) lp))
      )
    )
  )
  (if lp (vl-sort lp '(lambda(a b) (< (car a) (car b)))))
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla	(/	p1     p2     p3     p4	    paux   incx
		 incy	l      h      n	     maldato	   base
		 alfa	startX startY minX   minY   maxX   maxY
		)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
;;;  (setq	p1 (getpoint "\nIngrese un vertice de la region ")
;;;	p2 (getpoint p1 "\nIngrese el otro vertice ")
;;;  )
;;;  (command "LINE" p1 p2 "")
  (if (not (setq e (car (entsel "\nSelecciona el marco para la grilla..."))))
    (exit)
  )
  (setq l (dameEsquinas e)
	p1 (car l)
	p2 (cadr l)
	p3 (caddr l)
	l nil
  )
  (if (> (cadr p1) (cadr p2))		; siempre el p1 abajo
    (setq paux p1
	  p1 p2
	  p2 paux
    )
  )
  (setq	p3   (getpoint p1 "\nIngrese punto para Ancho de la region ")
	l    (distance p1 p3)		; calculo de puntos p3 y p4 , paralelos
	alfa (angle p1 p2)		; a p1 y p2 a distancia l
	alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
    (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
    (if	(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 0.0)
      (setq alfa (+ pi alfa))
    )
  )
  (setq	p3 (list (+ (car p1) (* l (cos alfa)))
		 (+ (cadr p1) (* l (sin alfa)))
	   )
	p4 (list (+ (car p2) (* l (cos alfa)))
		 (+ (cadr p2) (* l (sin alfa)))
	   )
  )
  (command "LINE" p1 p2 p4 p3 "C")	; marco exterior
  (if (< (cadr p3) (cadr p1))		; punto1 siempre mas bajo
    (setq paux p1
	  p1 p3
	  p3 paux
	  paux p2
	  p2 p4
	  p4 paux
    )
  )
  (setq	minX	(min (car p2) (car p3))
	maxX	(max (car p2) (car p3))
	minY	(cadr p1)
	maxY	(cadr p4)
	l	(- maxX minX)
	h	(- maxY minY)
	malDato	1
  )
  (while (= malDato 1)
    (setq incx (getreal "\nIncremento malla (m) :"))
    (if	(< (abs (/ l 3)) incrx)
      (print "\nIncremento muy grande")
      (setq malDato 0)
    )
  )

  (setq incy incx)

  (setq	n	 (fix (/ minX incx))	; posiciones donde comenzar
	startX	 (* (1+ n) incx)	; el cuadriculado
	n	 (fix (/ minY incy))	; tanto en X como en Y
	startY	 (* (1+ n) incy)
	largoMax (max (distance p1 p3)	; el largo maximo de la region
		      (distance p1 p4)
		 )
  )
  (if (< minX 0)
    (setq startX (- startX incx))
  )
  (if (< minY 0)
    (setq startY (- startY incy))
  )

  (setq ff (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala))	; alto de los caracteres

  (setq	angP1P3	 (angle p1 p3)
	angP1P2	 (angle p1 p2)
	angBorde (min (abs angP1P3) (abs angP1P2))
	dh	 (min (/ incx 40.0) (/ incy 40.0))
	x1	 minX			; el caso en que no hay que rotar
	x2	 maxX
	y1	 minY
	y2	 maxY
  )
  (if (or (= (cadr p1) (cadr p2))
	  (= (car p1) (car p3))
	  (= (car p1) (car p2))
      )
    (setq revisar 0
	  dl	  (min (/ incx 30.0) (/ incy 30.0))
    )
    (setq revisar 1
	  dl	  (* (* alto (/ (cos angBorde) (sin angBorde))) 2)
    )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
    (if	(= revisar 1)
      (setq ptos (IntersecX)
	    x1	 (car ptos)
	    x2	 (cadr ptos)
      )
    )
    (setq coordY (rtos startY 2 0)
	  coordY (strcat "N-" (strpto coordY))
    )
    (command "LINE" (list x1 startY) (list x2 startY) "")
    (cond ((> (- maxY startY) (* 2 alto))
	   (command "TEXT"
		    (list (+ x1 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	   (command "TEXT"
		    "R"
		    (list (- x2 dl) (+ startY dh))
		    alto
		    0
		    coordY
	   )
	  )
    )
    (setq startY (+ startY incy))
  )
  (while (< startX maxX)
    (if	(= revisar 1)
      (setq ptos (IntersecY)
	    y1	 (car ptos)
	    y2	 (cadr ptos)
      )

    )
    (setq coordX (rtos startX 2 0)
	  coordX (strcat "E-" (strpto coordX))
    )
    (command "LINE" (list startX y1) (list startX y2) "")
    (cond ((> (- startX minX) (* 2 alto))
	   (command "TEXT"
		    (list (- startX dh) (+ y1 dl))
		    alto
		    100
		    coordX
	   )
	   (command "TEXT"
		    "R"
		    (list (- startX dh) (- y2 dl))
		    alto
		    100
		    coordX
	   )
	  )
    )
    (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
    (setq alfa angP1P3)
    (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
    (setq alfarad (* -1 alfa)
	  alfa	  (* -1 (/ (* 200 alfa) pi))
	  p4	  (list	(- (* (car p4) (cos alfarad)) (* (cadr p4) (sin alfarad)))
			(+ (* (car p4) (sin alfarad)) (* (cadr p4) (cos alfarad)))
		  )
	  p1	  (list	(- (* (car p1) (cos alfarad)) (* (cadr p1) (sin alfarad)))
			(+ (* (car p1) (sin alfarad)) (* (cadr p1) (cos alfarad)))
		  )
	  base	  (list 0.0 0.0)	; el origen
    )
  )
  (command "_.undo" "end")
  (command "_.undo" "auto" "on")
  ;;  (command "units" "2" "3" "3" "4" "n" "y")
)

The "command" calls in your code are designed for an English version of AutoCAD, and mine is in Spanish.
For this reason, and due to lack of time, I haven't tested the code sufficiently.

Try it yourself and then comment on the results.

Dear friend GLAVCVS, thank you so much for your reply.
The routine worked perfectly.

I'm very grateful for your help.
Regards

2025-11-05T00:11:26Z

Could you post a sample drawing of what you would use this on and what your looking for. Rather then picking points for the grid you could do a selection and run the bounding box

(defun C:foo ()
  (if (setq SS (ssget))
    (BBOX)
    (command "_.RECTANG" LL UR)
    (prompt (strcat "El rectángulo mide: " (car L&W) " x " (cadr L&W)))
  )
  (princ)
)
;;----------------------------------------------------------------------------;;
;; Length and Width of a Selection 
(defun BBox (/ ptslst)
  (foreach ent (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
    (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
    (setq ptslst (cons (vlax-safearray->list minpt) ptslst)
          ptslst (cons (vlax-safearray->list maxpt) ptslst)
    )
  )
  (setq LL (apply 'mapcar (cons 'min ptslst))
        UR (apply 'mapcar (cons 'max ptslst))
        L&W (mapcar '- UR LL)
  )
  (princ)
)

2025-11-05T16:19:53Z

Hi GLAVCVS, can you help me? When creating a grid with Lisp,

is it possible to change the text style?

Specifically, change it from plain text to multiple text and add a 1.2 background mask.

Edited 9 hours ago by Omar ugarte

2025-11-05T21:26:58Z

Perhaps this will help you

(defun strpto (aa / largo)
  (setq largo (strlen aa))
  (cond	((< largo 4) aa)
	((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
	((= largo 7)
	 (strcat (substr aa 1 1)
		 "."
		 (substr aa 2 3)
		 "."
		 (substr aa 5 3)
	 )
	)
	(t aa)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
  (setq	a1 (- (cadr p2) (cadr p1))
	a2 (- (cadr p4) (cadr p2))
	a3 (- (cadr p3) (cadr p4))
	a4 (- (cadr p1) (cadr p3))
	b1 (- (car p1) (car p2))
	b2 (- (car p2) (car p4))
	b3 (- (car p4) (car p3))
	b4 (- (car p3) (car p1))
	c1 (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
	c2 (- (* (car p2) (cadr p4)) (* (car p4) (cadr p2)))
	c3 (- (* (car p4) (cadr p3)) (* (car p3) (cadr p4)))
	c4 (- (* (car p3) (cadr p1)) (* (car p1) (cadr p3)))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX	(a b c y)
  (if (= 0.0 a)				; no hay interseccion
    nil
    (/ (- c (* b y)) a)
  )
)

(Defun IntersecX (/ l lista)
  (setq	l     ()
	lista (list (CalculaX a1 b1 c1 startY)
		    (CalculaX a2 b2 c2 startY)
		    (CalculaX a3 b3 c3 startY)
		    (CalculaX a4 b4 c4 startY)
	      )
  )
  (while (/= lista nil)
    (setq x (car lista))
    (if	(and (/= x nil) (<= x maxX) (>= x minX))
      (setq l (append l (list x)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY	(a b c x)
  (if (= 0.0 b)				; no hay interseccion
    nil
    (/ (- c (* a x)) b)
  )
)

(Defun IntersecY (/ l lista)
  (setq	l     ()
	lista (list (CalculaY a1 b1 c1 startX)
		    (CalculaY a2 b2 c2 startX)
		    (CalculaY a3 b3 c3 startX)
		    (CalculaY a4 b4 c4 startX)
	      )
  )
  (while (/= lista nil)
    (setq y (car lista))
    (if	(and (/= y nil) (<= y maxY) (>= y minY))
      (setq l (append l (list y)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)

(defun dameEsquinas (e / le lp)
  (if (= (cdr (assoc 0 (setq le (entget e)))) "LWPOLYLINE")
    (foreach l le
      (if (= (car l) 10)
	(setq lp (cons (cdr l) lp))
      )
    )
  )
  (if lp (vl-sort lp '(lambda(a b) (< (car a) (car b)))))
)

(defun comando (tipobjeto punto altura rotacion texto j / color tamañoMascara)
  (setq color 1 tamañoMascara 1.2)
  (cond
    ((= tipobjeto "MTEXT")
      (entmake
	(list
	  '(0 . "MTEXT")
	  '(8 . "0")
	  '(100 . "AcDbEntity")
;;;	  '(410 . "Model")
	  '(100 . "AcDbMText")
	  (list 10 (+ x1 dl) (+ startY dh) 0.0)
;;;	  (cons 10 punto)
	  (cons 40 altura)
	  (cons 41 (* altura (strlen texto)))
	  (cons 71 (if j 9 (getvar "TEXTALIGNMODE")))
	  (cons 1 texto)
	  '(7 . "Standard")
					;;;	  '(210 0.0 0.0 1.0)
					;(11 0.896666 0.442707 0.0)
					;(42 . 236.19)
	  (cons 43 altura)
	  (cons 50 (angtof
		     (cond ((eq (setq p (type rotacion)) 'INT) (itoa rotacion))
			   ((eq p 'STR) p)
			   ((eq p 'REAL) (rtos p 2 2))
		     )
	           )
	  )
	  '(90 . 1)
	  (cons 63 (if color color 1))
	  (cons 45 (if tamañoMascara tamañoMascara 1.2))
	  '(441 . 0)
	)
      )
    )

    ((= tipobjeto "TEXT")
     (entmake (list '(0 . "TEXT")
		    '(8 . "0")
		    (cons 40 altura)
		    (cons 1 texto)
		    (list 10 (+ x1 dl) (+ startY dh) 0.0)
		    (cons 50 (angtof
				(cond ((eq (setq p (type rotacion)) 'INT) (itoa p))
				      ((eq p 'STR) p)
				      ((eq p 'REAL) (rtos p 2 2))
				)
			     )
		   ) 
	      )
     )
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla	(/	p1     p2     p3     p4	    paux   incx
		 incy	l      h      n	     maldato	   base
		 alfa	startX startY minX   minY   maxX   maxY
		)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
;;;  (setq	p1 (getpoint "\nIngrese un vertice de la region ")
;;;	p2 (getpoint p1 "\nIngrese el otro vertice ")
;;;  )
;;;  (command "LINE" p1 p2 "")
  (if (not (setq e (car (entsel "\nSelecciona el marco para la grilla..."))))
    (exit)
  )
  (setq l (dameEsquinas e)
	p1 (car l)
	p2 (cadr l)
	p3 (caddr l)
	l nil
  )
  (if (> (cadr p1) (cadr p2))		; siempre el p1 abajo
    (setq paux p1
	  p1 p2
	  p2 paux
    )
  )
  (setq	;p3   (getpoint p1 "\nIngrese punto para Ancho de la region ")
	l    (distance p1 p3)		; calculo de puntos p3 y p4 , paralelos
	alfa (angle p1 p2)		; a p1 y p2 a distancia l
	alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
    (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
    (if	(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 0.0)
      (setq alfa (+ pi alfa))
    )
  )
  (setq	p3 (list (+ (car p1) (* l (cos alfa)))
		 (+ (cadr p1) (* l (sin alfa)))
	   )
	p4 (list (+ (car p2) (* l (cos alfa)))
		 (+ (cadr p2) (* l (sin alfa)))
	   )
  )
  (command "LINE" p1 p2 p4 p3 "C")	; marco exterior
  (if (< (cadr p3) (cadr p1))		; punto1 siempre mas bajo
    (setq paux p1
	  p1 p3
	  p3 paux
	  paux p2
	  p2 p4
	  p4 paux
    )
  )
  (setq	minX	(min (car p2) (car p3))
	maxX	(max (car p2) (car p3))
	minY	(cadr p1)
	maxY	(cadr p4)
	l	(- maxX minX)
	h	(- maxY minY)
	malDato	1
  )
  (while (= malDato 1)
    (setq incx (getreal "\nIncremento malla (m) :"))
    (if	(< (abs (/ l 3)) incrx)
      (print "\nIncremento muy grande")
      (setq malDato 0)
    )
  )

  (setq incy incx)

  (setq	n	 (fix (/ minX incx))	; posiciones donde comenzar
	startX	 (* (1+ n) incx)	; el cuadriculado
	n	 (fix (/ minY incy))	; tanto en X como en Y
	startY	 (* (1+ n) incy)
	largoMax (max (distance p1 p3)	; el largo maximo de la region
		      (distance p1 p4)
		 )
  )
  (if (< minX 0)
    (setq startX (- startX incx))
  )
  (if (< minY 0)
    (setq startY (- startY incy))
  )

  (setq ff (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala))	; alto de los caracteres

  (setq	angP1P3	 (angle p1 p3)
	angP1P2	 (angle p1 p2)
	angBorde (min (abs angP1P3) (abs angP1P2))
	dh	 (min (/ incx 40.0) (/ incy 40.0))
	x1	 minX			; el caso en que no hay que rotar
	x2	 maxX
	y1	 minY
	y2	 maxY
  )
  (if (or (= (cadr p1) (cadr p2))
	  (= (car p1) (car p3))
	  (= (car p1) (car p2))
      )
    (setq revisar 0
	  dl	  (min (/ incx 30.0) (/ incy 30.0))
    )
    (setq revisar 1
	  dl	  (* (* alto (/ (cos angBorde) (sin angBorde))) 2)
    )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
    (if	(= revisar 1)
      (setq ptos (IntersecX)
	    x1	 (car ptos)
	    x2	 (cadr ptos)
      )
    )
    (setq coordY (rtos startY 2 0)
	  coordY (strcat "N-" (strpto coordY))
    )
    (command "LINE" (list x1 startY) (list x2 startY) "")
    (cond ((> (- maxY startY) (* 2 alto))
;;;	   (command "TEXT"
;;;		    (list (+ x1 dl) (+ startY dh))
;;;		    alto
;;;		    0
;;;		    coordY
;;;	   )
	   (comando "MTEXT" (list (+ x1 dl) (+ startY dh)) alto 0 coordY nil)
;;;	   (command "TEXT"
;;;		    "R"
;;;		    (list (- x2 dl) (+ startY dh))
;;;		    alto
;;;		    0
;;;		    coordY
;;;	   )
	   (comando "MTEXT" (list (- x2 dl) (+ startY dh)) alto 0 coordY T)
	  )
    )
    (setq startY (+ startY incy))
  )
  (while (< startX maxX)
    (if	(= revisar 1)
      (setq ptos (IntersecY)
	    y1	 (car ptos)
	    y2	 (cadr ptos)
      )

    )
    (setq coordX (rtos startX 2 0)
	  coordX (strcat "E-" (strpto coordX))
    )
    (command "LINE" (list startX y1) (list startX y2) "")
    (cond ((> (- startX minX) (* 2 alto))
;;;	   (command "TEXT"
;;;		    (list (- startX dh) (+ y1 dl))
;;;		    alto
;;;		    100
;;;		    coordX
;;;	   )
	   (comando "MTEXT" (list (- startX dh) (+ y1 dl)) alto 0 coordX nil)
;;;	   (command "TEXT"
;;;		    "R"
;;;		    (list (- startX dh) (- y2 dl))
;;;		    alto
;;;		    100
;;;		    coordX
;;;	   )
	   (comando "MTEXT" (list (- startX dh) (- y2 dl)) alto 0 coordX T)
	  )
    )
    (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
    (setq alfa angP1P3)
    (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
    (setq alfarad (* -1 alfa)
	  alfa	  (* -1 (/ (* 200 alfa) pi))
	  p4	  (list	(- (* (car p4) (cos alfarad)) (* (cadr p4) (sin alfarad)))
			(+ (* (car p4) (sin alfarad)) (* (cadr p4) (cos alfarad)))
		  )
	  p1	  (list	(- (* (car p1) (cos alfarad)) (* (cadr p1) (sin alfarad)))
			(+ (* (car p1) (sin alfarad)) (* (cadr p1) (cos alfarad)))
		  )
	  base	  (list 0.0 0.0)	; el origen
    )
  )
  (command "_.undo" "end")
  (command "_.undo" "auto" "on")
  ;;  (command "units" "2" "3" "3" "4" "n" "y")
)

2025-11-05T21:30:32Z

3 minutes ago, GLAVCVS said:

Perhaps this will help you

(defun strpto (aa / largo)
  (setq largo (strlen aa))
  (cond	((< largo 4) aa)
	((= largo 6) (strcat (substr aa 1 3) "." (substr aa 4 3)))
	((= largo 7)
	 (strcat (substr aa 1 1)
		 "."
		 (substr aa 2 3)
		 "."
		 (substr aa 5 3)
	 )
	)
	(t aa)
  )
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; DatosLineas : obtiene los coeficientes necesarios para determinar las
;;               rectas que definen el area a cuadricular. Las cuales son
;;               de la forma :  a*x + b*y = c
;;
(Defun DatosLineas (p1 p2 p3 p4)
  (setq	a1 (- (cadr p2) (cadr p1))
	a2 (- (cadr p4) (cadr p2))
	a3 (- (cadr p3) (cadr p4))
	a4 (- (cadr p1) (cadr p3))
	b1 (- (car p1) (car p2))
	b2 (- (car p2) (car p4))
	b3 (- (car p4) (car p3))
	b4 (- (car p3) (car p1))
	c1 (- (* (car p1) (cadr p2)) (* (car p2) (cadr p1)))
	c2 (- (* (car p2) (cadr p4)) (* (car p4) (cadr p2)))
	c3 (- (* (car p4) (cadr p3)) (* (car p3) (cadr p4)))
	c4 (- (* (car p3) (cadr p1)) (* (car p1) (cadr p3)))
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Punto de la recta dada por a,b,c dada la cordenada Y
;;
(Defun CalculaX	(a b c y)
  (if (= 0.0 a)				; no hay interseccion
    nil
    (/ (- c (* b y)) a)
  )
)

(Defun IntersecX (/ l lista)
  (setq	l     ()
	lista (list (CalculaX a1 b1 c1 startY)
		    (CalculaX a2 b2 c2 startY)
		    (CalculaX a3 b3 c3 startY)
		    (CalculaX a4 b4 c4 startY)
	      )
  )
  (while (/= lista nil)
    (setq x (car lista))
    (if	(and (/= x nil) (<= x maxX) (>= x minX))
      (setq l (append l (list x)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Interseccion dada la cordenada X
;;
(Defun CalculaY	(a b c x)
  (if (= 0.0 b)				; no hay interseccion
    nil
    (/ (- c (* a x)) b)
  )
)

(Defun IntersecY (/ l lista)
  (setq	l     ()
	lista (list (CalculaY a1 b1 c1 startX)
		    (CalculaY a2 b2 c2 startX)
		    (CalculaY a3 b3 c3 startX)
		    (CalculaY a4 b4 c4 startX)
	      )
  )
  (while (/= lista nil)
    (setq y (car lista))
    (if	(and (/= y nil) (<= y maxY) (>= y minY))
      (setq l (append l (list y)))
    )
    (setq lista (cdr lista))
  )
  (list (min (car l) (cadr l)) (max (car l) (cadr l)))
)

(defun dameEsquinas (e / le lp)
  (if (= (cdr (assoc 0 (setq le (entget e)))) "LWPOLYLINE")
    (foreach l le
      (if (= (car l) 10)
	(setq lp (cons (cdr l) lp))
      )
    )
  )
  (if lp (vl-sort lp '(lambda(a b) (< (car a) (car b)))))
)

(defun comando (tipobjeto punto altura rotacion texto j / color tamañoMascara)
  (setq color 1 tamañoMascara 1.2)
  (cond
    ((= tipobjeto "MTEXT")
      (entmake
	(list
	  '(0 . "MTEXT")
	  '(8 . "0")
	  '(100 . "AcDbEntity")
;;;	  '(410 . "Model")
	  '(100 . "AcDbMText")
	  (list 10 (+ x1 dl) (+ startY dh) 0.0)
;;;	  (cons 10 punto)
	  (cons 40 altura)
	  (cons 41 (* altura (strlen texto)))
	  (cons 71 (if j 9 (getvar "TEXTALIGNMODE")))
	  (cons 1 texto)
	  '(7 . "Standard")
					;;;	  '(210 0.0 0.0 1.0)
					;(11 0.896666 0.442707 0.0)
					;(42 . 236.19)
	  (cons 43 altura)
	  (cons 50 (angtof
		     (cond ((eq (setq p (type rotacion)) 'INT) (itoa rotacion))
			   ((eq p 'STR) p)
			   ((eq p 'REAL) (rtos p 2 2))
		     )
	           )
	  )
	  '(90 . 1)
	  (cons 63 (if color color 1))
	  (cons 45 (if tamañoMascara tamañoMascara 1.2))
	  '(441 . 0)
	)
      )
    )

    ((= tipobjeto "TEXT")
     (entmake (list '(0 . "TEXT")
		    '(8 . "0")
		    (cons 40 altura)
		    (cons 1 texto)
		    (list 10 (+ x1 dl) (+ startY dh) 0.0)
		    (cons 50 (angtof
				(cond ((eq (setq p (type rotacion)) 'INT) (itoa p))
				      ((eq p 'STR) p)
				      ((eq p 'REAL) (rtos p 2 2))
				)
			     )
		   ) 
	      )
     )
    )
  )
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Programa principal
;;
(Defun c:grilla	(/	p1     p2     p3     p4	    paux   incx
		 incy	l      h      n	     maldato	   base
		 alfa	startX startY minX   minY   maxX   maxY
		)
  (setvar "CMDECHO" 0)
  (command "_.undo" "_begin")
  (command "osnap" "off")
  (command "units" "2" "3" "3" "4" "e" "n")
  (command "LAYER" "M" "TO-GRILLA" "C" "8" "" "")
  (command "style" "romand" "romand" 0 1 0 "N" "N" "N")
  (setq incrx 0)
;;;  (setq	p1 (getpoint "\nIngrese un vertice de la region ")
;;;	p2 (getpoint p1 "\nIngrese el otro vertice ")
;;;  )
;;;  (command "LINE" p1 p2 "")
  (if (not (setq e (car (entsel "\nSelecciona el marco para la grilla..."))))
    (exit)
  )
  (setq l (dameEsquinas e)
	p1 (car l)
	p2 (cadr l)
	p3 (caddr l)
	l nil
  )
  (if (> (cadr p1) (cadr p2))		; siempre el p1 abajo
    (setq paux p1
	  p1 p2
	  p2 paux
    )
  )
  (setq	;p3   (getpoint p1 "\nIngrese punto para Ancho de la region ")
	l    (distance p1 p3)		; calculo de puntos p3 y p4 , paralelos
	alfa (angle p1 p2)		; a p1 y p2 a distancia l
	alfa (+ (/ pi 2) alfa)
  )
  (if (> (car p3) (car p1))
    (setq alfa (+ pi alfa))
  )
  (if (= (car p1) (car p3))
    (if	(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1))) 0.0)
      (setq alfa (+ pi alfa))
    )
  )
  (setq	p3 (list (+ (car p1) (* l (cos alfa)))
		 (+ (cadr p1) (* l (sin alfa)))
	   )
	p4 (list (+ (car p2) (* l (cos alfa)))
		 (+ (cadr p2) (* l (sin alfa)))
	   )
  )
  (command "LINE" p1 p2 p4 p3 "C")	; marco exterior
  (if (< (cadr p3) (cadr p1))		; punto1 siempre mas bajo
    (setq paux p1
	  p1 p3
	  p3 paux
	  paux p2
	  p2 p4
	  p4 paux
    )
  )
  (setq	minX	(min (car p2) (car p3))
	maxX	(max (car p2) (car p3))
	minY	(cadr p1)
	maxY	(cadr p4)
	l	(- maxX minX)
	h	(- maxY minY)
	malDato	1
  )
  (while (= malDato 1)
    (setq incx (getreal "\nIncremento malla (m) :"))
    (if	(< (abs (/ l 3)) incrx)
      (print "\nIncremento muy grande")
      (setq malDato 0)
    )
  )

  (setq incy incx)

  (setq	n	 (fix (/ minX incx))	; posiciones donde comenzar
	startX	 (* (1+ n) incx)	; el cuadriculado
	n	 (fix (/ minY incy))	; tanto en X como en Y
	startY	 (* (1+ n) incy)
	largoMax (max (distance p1 p3)	; el largo maximo de la region
		      (distance p1 p4)
		 )
  )
  (if (< minX 0)
    (setq startX (- startX incx))
  )
  (if (< minY 0)
    (setq startY (- startY incy))
  )

  (setq ff (getreal "\nIngrese Alto (mm) :"))
  (setq escala (getreal "\nEscala            : "))
  (setq alto (* (/ ff 1000) escala))	; alto de los caracteres

  (setq	angP1P3	 (angle p1 p3)
	angP1P2	 (angle p1 p2)
	angBorde (min (abs angP1P3) (abs angP1P2))
	dh	 (min (/ incx 40.0) (/ incy 40.0))
	x1	 minX			; el caso en que no hay que rotar
	x2	 maxX
	y1	 minY
	y2	 maxY
  )
  (if (or (= (cadr p1) (cadr p2))
	  (= (car p1) (car p3))
	  (= (car p1) (car p2))
      )
    (setq revisar 0
	  dl	  (min (/ incx 30.0) (/ incy 30.0))
    )
    (setq revisar 1
	  dl	  (* (* alto (/ (cos angBorde) (sin angBorde))) 2)
    )

  )
  (DatosLineas p1 p2 p3 p4)
  (while (< startY maxY)
    (if	(= revisar 1)
      (setq ptos (IntersecX)
	    x1	 (car ptos)
	    x2	 (cadr ptos)
      )
    )
    (setq coordY (rtos startY 2 0)
	  coordY (strcat "N-" (strpto coordY))
    )
    (command "LINE" (list x1 startY) (list x2 startY) "")
    (cond ((> (- maxY startY) (* 2 alto))
;;;	   (command "TEXT"
;;;		    (list (+ x1 dl) (+ startY dh))
;;;		    alto
;;;		    0
;;;		    coordY
;;;	   )
	   (comando "MTEXT" (list (+ x1 dl) (+ startY dh)) alto 0 coordY nil)
;;;	   (command "TEXT"
;;;		    "R"
;;;		    (list (- x2 dl) (+ startY dh))
;;;		    alto
;;;		    0
;;;		    coordY
;;;	   )
	   (comando "MTEXT" (list (- x2 dl) (+ startY dh)) alto 0 coordY T)
	  )
    )
    (setq startY (+ startY incy))
  )
  (while (< startX maxX)
    (if	(= revisar 1)
      (setq ptos (IntersecY)
	    y1	 (car ptos)
	    y2	 (cadr ptos)
      )

    )
    (setq coordX (rtos startX 2 0)
	  coordX (strcat "E-" (strpto coordX))
    )
    (command "LINE" (list startX y1) (list startX y2) "")
    (cond ((> (- startX minX) (* 2 alto))
;;;	   (command "TEXT"
;;;		    (list (- startX dh) (+ y1 dl))
;;;		    alto
;;;		    100
;;;		    coordX
;;;	   )
	   (comando "MTEXT" (list (- startX dh) (+ y1 dl)) alto 0 coordX nil)
;;;	   (command "TEXT"
;;;		    "R"
;;;		    (list (- startX dh) (- y2 dl))
;;;		    alto
;;;		    100
;;;		    coordX
;;;	   )
	   (comando "MTEXT" (list (- startX dh) (- y2 dl)) alto 0 coordX T)
	  )
    )
    (setq startX (+ startX incx))
  )
  (if (> (distance p1 p3) (distance p1 p2))
    (setq alfa angP1P3)
    (setq alfa angP1P2)
  )
  (if (or (/= alfa pi) (/= alfa 0.0))
    (setq alfarad (* -1 alfa)
	  alfa	  (* -1 (/ (* 200 alfa) pi))
	  p4	  (list	(- (* (car p4) (cos alfarad)) (* (cadr p4) (sin alfarad)))
			(+ (* (car p4) (sin alfarad)) (* (cadr p4) (cos alfarad)))
		  )
	  p1	  (list	(- (* (car p1) (cos alfarad)) (* (cadr p1) (sin alfarad)))
			(+ (* (car p1) (sin alfarad)) (* (cadr p1) (cos alfarad)))
		  )
	  base	  (list 0.0 0.0)	; el origen
    )
  )
  (command "_.undo" "end")
  (command "_.undo" "auto" "on")
  ;;  (command "units" "2" "3" "3" "4" "n" "y")
)

If you want to change the mask's color or size, look for the variables "color" and "tamañoMascara" and change their values.

Currently, their values are 1 (red) and 1.2, respectively.

2025-11-05T22:12:06Z

here is a lisp that I'm using.

make sure to set "TEXTSIZE" varaible to the text size value you need before ruuning it.

;  KoordinatenRand.lsp    Lisp-datei zum Zeichnen von Koordinaten an Ansichtsfenster
;  erstellt 12/03  Th.J.
;           06/07  einfaches Errorhandling hinzugefuegt
;           06/07  Fehler bei Abweichung von Koordinatenrichtung und Winkeleinheiten beseitigt
;           09/07  Auswahl ob Anschreiben innen oder aussen vom AF
;	    26/17  cadde interna.commands
;
;  Vorhaben: waehle Ansichtsfenter und zeichne im Plotbereich an das AF die Koordinaten (Linien und Werte)
;            des dargestellten (Lage)planausschnittes
;
;
;;(princ "Start with coordinate border")

; Errorhandling
(defun my_error (msg)
  (print (strcat "Error occurred: " msg))
  (command "_undo" "_back")
  (setq *error* alterror)
  (setvar "blipmode" sblip)
  (setvar "cmdecho" scmde)
  (setvar "osmode" sosmode)
  (setvar "angbase" sangbase)
  (setvar "angdir" sangdir)
  (setvar "aunits" saunits) 

  (princ)
)
 ;
(defun antwort(frage antw1 antw2 / antw kw)
  (setq kw (strcat antw1 " " antw2))
  (initget 1 kw)
  (setq antw (substr (getkword frage) 1 1))
) ; ende defun antwort

(defun Txtin (ptin hgt str j72 j73 ang / )
 (entmakex 
    (list (cons 0 "TEXT")
          (cons 10  ptin)
          (cons 11  ptin)
          (cons 40 hgt)
          (cons 50 ang)
          (cons 1  str)
          (cons 72  j72)
          (cons 73  j73)
    )
 )
)

(defun drln (ptst ptend / )
 (entmakex 
    (list (cons 0 "LINE")
          (cons 10  ptst)
          (cons 11  ptend)
    )
 )
)


(defun drec (pll plr pur pul / )
 (entmake
    (list
      (cons 0 "LWPOLYLINE")
      (cons 100 "AcDbEntity")
      (cons 100 "AcDbPolyline")
      (cons 90 4) ;Number of vertices
      (cons 70 1) ; closed = 1,open=0
      (cons 10 pll) 
      (cons 10 plr)
      (cons 10 pur)
      (cons 10 pul)
    ) 
 ) 
)


 ; jetzt gehts los
 ;
(defun C:KoordinatenRand_Ms( / alterror sblip scmd sosmode al anz x axl zen_af zen_af_x zen_af_y zen_modw zen_mod_xw zen_mod_yw
		    br_af h_af h_mod affakt br_mod alpha
		    element punkte liun_mb liob_mb reun_mb reob_mb liun_mb_x liob_mb_x reun_mb_x
		    reob_mb_x liun_mb_y liob_mb_y reun_mb_y reob_mb_y startx starty delta_l delta_m cy_af
		    richtg textht textri textausri textausri1 cx_mb minx maxx delta_m1 cx_af ctext p1 p2 pt cy_mb miny maxy txtpos txtlndist upnum dwnum textri2
                    pt1 txtpos2 plent co-ord ptx1 pty1 ptx2 pty2 ptx3 pty3 ptx4 pty4 minxm minym maxxm maxym jstt72 jstt73 jstb72 jstb73 txtlen lenctext
                    vppt1 vppt2 vppt3 vppt4
                )
(vl-load-com)

 (setq alterror *error*)
 (setq *error* my_error)
 (command "_undo" "_mark")

 (setq textht (getvar "TEXTSIZE"))
 (setq textht2 (* textht 0.75));;char (number) width to calculate line length
 (setq textht3 (* textht 0.296));; offset distance for text with top justification

 (print "Ansichtsfensterkoordinaten")
 ;
 ; ein paar vorbereitungen
 ;
 (setq sblip (getvar "blipmode"))
 (setq scmde (getvar "cmdecho"))
 (setq sosmode (getvar "osmode"))
 (setq sangbase (getvar "angbase"))
 (setq sangdir (getvar "angdir"))
 (setq saunits (getvar "aunits")) 
 (setvar "blipmode" 0)
 (setvar "cmdecho" 0)
 (setvar "osmode" 0)
 (setvar "angbase" 0)
 (setvar "angdir" 0)
 (setvar "aunits" 0) 

 
 ;  waehle Fenster
 (prompt "\nSelect Rectangle Frame: ")
 (setq anz 0 al (ssget '((0 . "LWPOLYLINE"))))
 ;(setq anz (sslength al))
 (if al (setq anz (sslength al)) (print "no rectangle selected"))
 (setq x 0)
 (while (< x anz)
   (setq axl (entget (ssname al x)))

   ;
   ; pruefen ob ansichtsfenster
   ;
   (if (= "LWPOLYLINE" (cdr (assoc 0 axl)))
       (progn
          (setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget (ssname al x))))) ;make list of the rectangle points

          (setq ptx1 (car (nth 0 co-ord)))
          (setq pty1 (cadr (nth 0 co-ord)))

          (setq ptx2 (car (nth 1 co-ord)))
          (setq pty2 (cadr (nth 1 co-ord)))

          (setq ptx3 (car (nth 2 co-ord)))
          (setq pty3 (cadr (nth 2 co-ord)))

          (setq ptx4 (car (nth 3 co-ord)))
          (setq pty4 (cadr (nth 3 co-ord)))

          (setq minxm (min ptx1 ptx2 ptx3 ptx4))
          (setq minym (min pty1 pty2 pty3 pty4))

          (setq maxxm (max ptx1 ptx2 ptx3 ptx4))
          (setq maxym (max pty1 pty2 pty3 pty4))

          (setq alpha 0) ;Rectangle twist angle
          ;
          ;
          ; eckpunkte ansichtsfenster (annahme nicht gedreht) (vertices viewport (assuming not rotated))
          ;
          ;
          ;  OK bis hier, nun koordinaten der Eckpunkte fuer Modellbereich ermitteln (OK up to here, now determine the coordinates of the corner points for the model area)
          ;
          ; dafür haben wir im lisp forum etwas gefunden (We found something for this in the lisp forum)

          (setq liun_mb (list minxm minym)) ;lower left model space point 
          (setq reun_mb (list maxxm minym)) ;lower right model space point
          (setq reob_mb (list maxxm maxym)) ;upper right model space point 
          (setq liob_mb (list minxm maxym)) ;upper left model space point
          (setq liun_mb_x (car liun_mb)) ;lower left model space point X liun_af_x
          (setq liun_mb_y (cadr liun_mb)) ;lower left model space point Y liun_af_y
          (setq liob_mb_x (car liob_mb)) ;upper left model space point X liob_af_x
          (setq liob_mb_y (cadr liob_mb)) ;upper left model space point Y liob_af_y
          (setq reun_mb_x (car reun_mb)) ;lower right model space point X reun_af_x
          (setq reun_mb_y (cadr reun_mb)) ;lower right model space point Y reun_af_y
          (setq reob_mb_x (car reob_mb)) ;upper right model space point X reob_af_x
          (setq reob_mb_y (cadr reob_mb)) ;upper right model space point Y reob_af_y
          ;
          ; Ausgabe Extremwerte und Abfrage Startwerte und Schrittweiten
          ;
          (print "Mininmal- und Maximalwert x ")
          (princ (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x))
          (princ "  ")
          (princ "  ")
          (princ (max liun_mb_x liob_mb_x reun_mb_x reob_mb_x))
          (print "Mininmal- und Maximalwert y")
          (princ (min liun_mb_y liob_mb_y reun_mb_y reob_mb_y))
          (princ "  ")
          (princ "  ")
          (princ (max liun_mb_y liob_mb_y reun_mb_y reob_mb_y))

          (setq optminx (/ (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x) 100))
          (setq optminx (* (atof (rtos optminx 2 0)) 100))

          (setq optminy (/ (min liun_mb_y liob_mb_y reun_mb_y reob_mb_y) 100))
          (setq optminy (* (atof (rtos optminy 2 0)) 100))

          ;(terpri)

          (setq startx (getreal (strcat "\nSpecify starting value for x coordinates: <" (rtos optminx 2 2) ">")))
          (if (= startx nil)
           (setq startx optminx)
          )          

          (setq starty (getreal (strcat "\nSpecify starting value for x coordinates: <" (rtos optminy 2 2) ">")))
          (if (= starty nil)
           (setq starty optminy)
          )          


          ;(initget 3)
          (setq delta_l (getreal "\nSpecify step size for coordinates: <100.00>" ))
          (if (= delta_l nil)
           (setq delta_l 100)
          )          

          (setq txtpos (getreal "Specify text dist. from frame: : <1.00> "))
          (if (= txtpos nil)
           (setq txtpos 1)
          )
       
          (setq textht1 txtpos);; line exstention from the end of the longest number - center the longest number on the line(* textht 0.25));;

      	  (setq lraussen (= (antwort "\nCoordinates inside-I/outside-A of the AF [I/A] :" "Innen" "Aussen") "A"))

          ;;;; Create the frames
          ;; find max text length for X value      
          (setq l1 (strlen (rtos (min liun_mb_x liob_mb_x reun_mb_x reob_mb_x) 2 0)))
          (setq l2 (strlen (rtos (max liun_mb_x liob_mb_x reun_mb_x reob_mb_x) 2 0)))
          (setq lmax (max l1 l2))

          (if (< lmax 7) 
            (setq txtlenx 3)
            (setq txtlenx (- lmax 3))
          ) 
               
          (setq txtlndistx (+ txtpos textht1 (* txtlenx textht2)));;offset value for X



          ;; find max text length for Y value  
          (setq l1 (strlen (rtos (min liun_mb_y liob_mb_y reun_mb_y reob_mb_y) 2 0)))
          (setq l2 (strlen (rtos (max liun_mb_y liob_mb_y reun_mb_y reob_mb_y) 2 0)))
          (setq lmax (max l1 l2))

          (if (< lmax 7) 
            (setq txtleny 3)
            (setq txtleny (- lmax 3))
          )
  
          (setq txtlndisty (+ txtpos textht1 (* txtleny textht2)));;offset value for Y


          (if lraussen ;; Frame Outside
            (progn
              (setq vppt1 (list (- liun_mb_x txtlndisty) (- liun_mb_y txtlndistx) 0)) ;lower left viewport point
              (setq vppt2 (list (+ reun_mb_x txtlndisty) (- reun_mb_y txtlndistx) 0)) ;lower right viewport point  
              (setq vppt3 (list (+ reob_mb_x txtlndisty) (+ reob_mb_y txtlndistx) 0)) ;upper right viewport point   
              (setq vppt4 (list (- liun_mb_x txtlndisty) (+ liob_mb_y txtlndistx) 0)) ;upper left viewport point 
            )
            (progn ; Frame inside
              (setq vppt1 (list (+ liun_mb_x txtlndisty) (+ liun_mb_y txtlndistx) 0)) ;lower left viewport point
              (setq vppt2 (list (- reun_mb_x txtlndisty) (+ reun_mb_y txtlndistx) 0)) ;lower right viewport point  
              (setq vppt3 (list (- reob_mb_x txtlndisty) (- reob_mb_y txtlndistx) 0)) ;upper right viewport point   
              (setq vppt4 (list (+ liun_mb_x txtlndisty) (- liob_mb_y txtlndistx) 0)) ;upper left viewport point 
            )            
          );;end if            

          (drec vppt1 vppt2 vppt3 vppt4)



          ;
          ; Werte pruefen und setzen (lassen wir noch offen)
          ;
          ;
          ; jetzt gehts richtig los
          ;
          ; unterer Rand, x werte
          ;
          (setq delta_m (- reun_mb_x liun_mb_x))  ; dargestellte Koord.diff im Modellb. (Coord.diff shown in the model.)
          (setq cy_af liun_mb_y)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))  ; Richtg. der Linie in Abh. von Drehung MB in AF (Direction the line depending on rotation MB in AF)
            (setq richtg (- alpha (/ pi 2.)))
            (setq richtg (+ alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))   ; nur Richtung 0 .. 2pi zulaessig
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))

          (if (< richtg (/ pi 2))                 ; Textrichtg. in Abh. von Linienrichtg.
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "br" "bl"))
            ) ; end progn
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "bl" "br"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
          (setq cx_mb startx)
          (setq minx (min liun_mb_x reun_mb_x))  ; es kann auch in negativer Richtung verlaufen
          (setq maxx (max liun_mb_x reun_mb_x))
          (while (<= cx_mb minx)                 ; ersten auf Rand im MB vorh. Wert ermitteln
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb liun_mb_x))  ; Streckenverhaeltnisse
            (setq cx_af (+ liun_mb_x delta_m1))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )
            
            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndistx))
            (setq pt (polar p1 richtg (/ txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")


            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73
            ;(command "_.text" "_j" textausri pt textht textri upnum)            
            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb


          ; oberer Rand, x werte
          ;
          (setq delta_m (- reob_mb_x liob_mb_x))
          (setq cy_af liob_mb_y)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
            (setq richtg (+ alpha (/ pi 2.)))
            (setq richtg (- alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))

          (if (< richtg (* pi 1.5))
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "bl" "br"))
            ) ; end progn
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "br" "bl"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
          (setq cx_mb startx)
          (setq minx (min liob_mb_x reob_mb_x))
          (setq maxx (max liob_mb_x reob_mb_x))
          (while (<= cx_mb minx)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb liob_mb_x))
            (setq cx_af (+ liob_mb_x delta_m1))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndistx))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73
            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
            ;   (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb

          ; linker Rand, x werte
          ;
          (setq delta_m (- liob_mb_x liun_mb_x))
          (setq cx_af liun_mb_x)
          (if (> alpha pi)
            (setq richtg (+ alpha (/ pi 2.)))
            (setq richtg (- alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
    
          (setq textri (/ (* richtg 180 ) pi))
;	  (setq textausri "bl")
          (setq textausri (if lraussen "br" "bl"))
	  (if lraussen (setq richtg (+ richtg pi)))
          
          (setq cx_mb startx)
          (setq minx (min liob_mb_x liun_mb_x))
          (setq maxx (max liob_mb_x liun_mb_x))
          (while (<= cx_mb minx)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb liun_mb_x))
            (setq cy_af (+ liun_mb_y delta_m1))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndistx))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73

            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
             ;  (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb

          ; rechter Rand, x werte
          ;
          (setq delta_m (- reob_mb_x reun_mb_x))
          (setq cx_af reun_mb_x)
          (if (< alpha pi)
            (setq richtg (+ alpha (/ pi 2.)))
            (setq richtg (- alpha (/ pi 2.)))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))
         
          (setq textri (/ (* (- richtg pi) 180 ) pi))
          (setq textausri (if lraussen "bl" "br"))
	  (if lraussen (setq richtg (+ richtg pi)))
          
          (setq cx_mb startx)
          (setq minx (min reob_mb_x reun_mb_x))
          (setq maxx (max reob_mb_x reun_mb_x))
          (while (<= cx_mb minx)
            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb
          (while (< cx_mb maxx)
            (setq delta_m1 (- cx_mb reun_mb_x))
            (setq cy_af (+ reun_mb_y delta_m1))
            (setq ctext (rtos cx_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndistx))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73

            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
            ;   (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cx_mb (+ cx_mb delta_l))
          ) ; end while cx_mb


          ; linker Rand, y werte
          ;
          (setq delta_m (- liob_mb_y liun_mb_y))
          (setq cx_af liun_mb_x)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
            (setq richtg (+ pi alpha))
            (setq richtg (+ alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))

          (setq textausri (if lraussen "br" "bl"))
          (setq textri (/ (* richtg 180 ) pi))
	  (if lraussen (setq richtg (+ richtg pi)))
	 
          (setq cy_mb starty)
          (setq miny (min liob_mb_y liun_mb_y))
          (setq maxy (max liob_mb_y liun_mb_y))
	 
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb liun_mb_y))
            (setq cy_af (+ liun_mb_y delta_m1))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndisty))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73

            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
            ;   (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb


          ; rechter Rand, y werte
          ;
          (setq delta_m (- reob_mb_y reun_mb_y))
          (setq cx_af reun_mb_x)
          (if (and (> alpha (/ pi 2.)) (< alpha (* 3 (/ pi 2.))))
            (setq richtg (+ alpha))
            (setq richtg (+ pi alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))

          (setq textri (/ (* (- richtg pi) 180 ) pi))
          (setq textausri (if lraussen "bl" "br"))
	  (if lraussen (setq richtg (+ richtg pi)))
	
          (setq cy_mb starty)
          (setq miny (min reun_mb_y reob_mb_y))
          (setq maxy (max reun_mb_y reob_mb_y))
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb reun_mb_y))
            (setq cy_af (+ reun_mb_y delta_m1))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndisty))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73

            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
            ;   (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb

          ; unterer Rand, y werte
          ;
          (setq delta_m (- reun_mb_y liun_mb_y))
          (setq cy_af liun_mb_y)
          (if (< alpha pi)
            (setq richtg (+ alpha))
            (setq richtg (+ pi alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))

          (if (< richtg (/ pi 2))
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "br" "bl"))
            ) ; end progn
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "bl" "br"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
          
          (setq cy_mb starty)
          (setq miny (min liun_mb_y reun_mb_y))
          (setq maxy (max liun_mb_y reun_mb_y))
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb liun_mb_y))
            (setq cx_af (+ liun_mb_x delta_m1))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndisty))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))

            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73

            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
            ;   (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb

          ; oberer Rand, y werte
          ;
          (setq delta_m (- reob_mb_y liob_mb_y))
          (setq cy_af liob_mb_y)
          (if (< alpha pi)
            (setq richtg (+ pi alpha))
            (setq richtg (+ alpha))
          ) ; end if 
          (if (< richtg 0) (setq richtg (+ richtg pi pi)))
          (if (> richtg (* 2 pi)) (setq richtg (- richtg pi pi)))

          (if (< richtg (* pi 1.5))
            (progn (setq textri (/ (* (- richtg pi) 180 ) pi))
                   (setq textausri (if lraussen "bl" "br"))
            ) ; end progn
            (progn (setq textri (/ (* richtg 180 ) pi))
                   (setq textausri (if lraussen "br" "bl"))
            ) ; end progn
          ) ; end if
	  (if lraussen (setq richtg (+ richtg pi)))
          
          (setq cy_mb starty)
          (setq miny (min liob_mb_y reob_mb_y))
          (setq maxy (max liob_mb_y reob_mb_y))
          (while (<= cy_mb miny)
            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb
          (while (< cy_mb maxy)
            (setq delta_m1 (- cy_mb liob_mb_y))
            (setq cx_af (+ liob_mb_x delta_m1))
            (setq ctext (rtos cy_mb 2 0))
            (setq p1 (list cx_af cy_af))

            (if (= (- (strlen ctext) 3) 0)
              (setq upnum "0")
              (setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            )

            ;(setq upnum (substr ctext 1 (- (strlen ctext) 3))) ;top number
            (setq dwnum (substr ctext (- (strlen ctext) 2) (strlen ctext)))

            ;(setq txtlen (max (strlen upnum) (strlen dwnum)))
            ;(setq txtlndist (+ txtpos textht1 (* txtlen textht2)))
            (setq p2 (polar p1 richtg txtlndisty))
            (setq pt (polar p1 richtg ( / txtlndistx 2)))
            (drln p1 p2) 
            ;(command "_.line" p1 p2 "")

            (setq textri2 (- textri 90))
            (setq pt1 (polar pt (* (/ textri2 180) pi) textht3))

            (if ( = textausri "br");jstt72 jstt73 jstb72 jstb73
              (progn ;br
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top
               (setq textausri1 "tr")
              )
              (progn ;bl
               (setq jstt72 1) ;center
               (setq jstt73 1) ;bottom
               (setq jstb72 1) ;center
               (setq jstb73 3) ;top                
               (setq textausri1 "tl")
              )          
            )

            (Txtin pt textht upnum jstt72 jstt73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73 ang
            (Txtin pt1 textht dwnum jstb72 jstb73 (* (/ textri 180) pi)) ;ptin hgt str j72 j73

            ;(command "_.text" "_j" textausri pt textht textri upnum)
            
            ;(if ( = textausri "br")
            ;   (setq textausri1 "tr")
            ;   (setq textausri1 "tl")             
            ;)

            ;(command "_.text" "_j" textausri1 pt1 textht textri dwnum)

            (setq cy_mb (+ cy_mb delta_l))
          ) ; end while cy_mb

	 ) ;end progn
   ) ; end if viewport
   (setq x (1+ x))
 )
 ;
 ; Ausgangsbedingungen wieder herstellen
 ;
 (setvar "blipmode" sblip)
 (setvar "cmdecho" scmde)
 (setvar "osmode" sosmode)
 (setvar "angbase" sangbase)
 (setvar "angdir" sangdir)
 (setvar "aunits" saunits) 
 (setq *error* alterror)
 (prompt "Coordinates set")
 (princ)

)

Sign In

help to improve lisp routine, (coordinate grid)

Recommended Posts

Omar ugarte

GLAVCVS

Omar ugarte

mhupp

Omar ugarte

GLAVCVS

GLAVCVS

aridzv

Join the conversation

Tutorials

Forums

Activity