Rutina DTencad

A peticion de un usuario aqui dejo el codigo fuente de la rutina DTencad.lsp
Version corregida 24/02/2024

Código:

 ; Acota por cadenamiento desde inicio elegido de polilinea. (punto a punto, distancias ó tramos fijos)
;;;================================================================================================
(defun dialog_encad ()
  (setq file (vl-filename-mktemp nil nil ".dcl"))
  (setq indi (open file "W"))
  (foreach str ;
          (list
            "temp:dialog{label=\" Cuadro de Cadenamiento  :copyright:2013\";" ;
            "  :row{" ;
            "    :boxed_column{label=\" Altura Texto \";" ;
            "      :edit_box{allow_accept=true;fixed_width_font=true;" ;
            "        edit_width=3;edit_limit=4;key=\"altxt\";}" ;
            "    }" ;
            "    :boxed_column{label=\" Decimales \";" ;
            "      :edit_box{allow_accept=true;fixed_width_font=true;" ;
            "        edit_width=0.5;edit_limit=1;key=\"dec\";}" ;
            "    }" ;
            "    :boxed_column{label=\" Prefijo \";" ;
            "      :edit_box{fixed_width_font=true;allow_accept=true;edit_width=8;key=\"pre\";}" ;
            "    }" ;
            "  }" ;
            "  :row{" ;
            "    :boxed_column{label=\" Modos \";" ;
            "      :radio_button{label=\"Indicar Puntos\";key=\"ip\";}" ;
            "      :radio_button{label=\"Indicar Distancias\";key=\"id\";}" ;
            "      :radio_button{label=\"Indicar Tramos\";key=\"it\";}" ;
            "      :radio_button{label=\"Distancia Fija\";key=\"df\";}" ;
            "    }" ;
            "    :boxed_column{label=\" Marcas \";" ;
            "      :radio_button{label=\"Trazo\";key=\"traz\";}" ;
            "      :radio_button{label=\"Punto\";key=\"pnt\";}" ;
            "      :radio_button{label=\"Circulito\";key=\"cir\";}" ;
            "      :edit_box{label=\"Distancia Fija\";fixed_width_font=true;" ;
            "        allow_accept=true;edit_width=5;key=\"fija\";" ;
            "      }" ;
            "      spacer;" ;
            "    }" ;
            "  }" ;
            "  :boxed_column{label=\" Indicaciones \";" ;
            "    :errtile{alignment=centered;fixed_width_font=true;}" ;
            "  }" ;
            "  spacer;" ;
            "  ok_cancel_help;" ;
            "  :boxed_column{label=\" Luis Dominguez Gómez  :copyright: 2007 \";fixed_width=true;alignment=centered;"
            "    :text{key=\"fecha\";alignment=centered;}" ;
            "  }" ;
            "}" "ayuda_encad:dialog{label=\" Ayuda  D T E N C A D\";" ;
            "  :list_box{key=\"lista\";fixed_width_font=true;height=20;width=85;}" ;
            "  :row{" ;
            "    :boxed_column{label=\"Autor y propietario\";" ;
            "      :text{label=\"LUIS DOMINGUEZ GÓMEZ :copyright: 2007\";fixed_width_font=true;" ;
            "        alignment=centered;is_enabled=false;}" ;
            "    }" ;
            "    ok_only;" ;
            "  }" ;
            "}" ;
            )
    (write-line str indi)
  )
  (close indi)
)
;;;================================================================================================
(defun rag (r) (/ (* r 180.0) pi))
;;;================================================================================================
(defun indi_ptos ()
  (mapcar 'mode_tile '("fija" "traz" "cir") '(1 0 0))
  (set_tile "fija" "")
  (if *pre*
    (set_tile "pre" *pre*)
    (set_tile "pre" "PK ")
  )
  (setq opc "ip")
)
;;;================================================================================================
(defun indi_dist ()
  (mapcar 'mode_tile '("fija" "traz" "cir") '(1 0 0))
  (set_tile "fija" "")
  (if *pre*
    (set_tile "pre" *pre*)
    (set_tile "pre" "PK ")
  )
  (setq opc "id")
)
;;;================================================================================================
(defun indi_tram ()
  (mapcar 'mode_tile '("fija" "traz" "cir") '(1 1 1))
  (mapcar 'set_tile '("fija" "pnt" "pre") '("" "1" ""))
  (setq mar "pnt")
  (setq opc "it")
)
;;;================================================================================================
(defun dist_fija ()
  (mapcar 'mode_tile '("fija" "traz" "cir") '(0 0 0))
  (if *tramos*
    (set_tile "fija" (rtos *tramos* 2 2))
    (set_tile "fija" "")
  )
  (if *pre*
    (set_tile "pre" *pre*)
    (set_tile "pre" "PK ")
  )
  (setq opc "df")
)
;;;================================================================================================
(defun cuadro_encad ()
  (if (> *scl* 0.00)
    (set_tile "altxt" (rtos *scl* 2 2))
    (set_tile "altxt" "")
  )
  (if *dec*
    (set_tile "dec" (itoa *dec*))
    (set_tile "dec" "")
  )
  (if *pre*
    (set_tile "pre" *pre*)
    (set_tile "pre" "PK ")
  )
  (mode_tile "fija" 1)
  (setq opc "ip")
  (setq mar "trz")
  (mapcar 'action_tile
          '("ip" "df" "id" "it" "traz" "pnt" "cir" "accept" "cancel" "help")
          '("(indi_ptos)" "(dist_fija)" "(indi_dist)" "(indi_tram)" "(setq mar \"trz\")"
            "(setq mar \"pnt\")" "(setq mar \"crl\")" "(ok_encad)" "(exit)" "(ayuda_encad)"
          )
  )
  (mapcar 'set_tile '("fija" "ip" "traz") '("" "1" "1"))
  (set_tile "fecha" (menucmd "M=$(edtime, $(getvar,date),DDDD\"\" DD MONTH YYYY - HH:MM am/pm)"))
)
;;;================================================================================================
(defun ayuda_encad ()
  (new_dialog "ayuda_encad" indi)
  (start_list "lista")
  (mapcar 'add_list
          (list
            "* La ALTURA de TEXTO es obligatoria. (Introducir por primera vez)"
            "  (Siempre se puede cambiar, pero recuerda la ultima ALTURA usada)" ;
            " " ;
            "* La CANTIDAD de DECIMALES es obligatoria. (Introducir por primera vez)"
            "  (Siempre se puede cambiar, pero recuerda la ultima CANTIDAD de DECIMALES usada)" ;
            " " ;
            "* El PREFIJO nó es obligatorio." ;
            "  (Si lo introduces por primera vez, recuerda el ultimo PREFIJO usado)" ;
            " " ;
            "* La DISTANCIA FIJA nó es obligatoria." ;
            "  (Es la distancia fija a la que se dibujaran todos los puntos," ;
            "  hasta el final de la polilinea)" ;
            " " ;
            "* Tocar la polilinea cerca del extremo desde donde queramos iniciar."
            "  (Excepto para acotar tramos, que se puede tocar la polilinea en cualquier lugar)."
          )
  )
  (end_list)
  (action_tile "accept" "(done_dialog 1)")
  (start_dialog)
)
;;;================================================================================================
(defun ok_encad ()
  (setq *scl* (atof (get_tile "altxt")))
  (setq *pre* (get_tile "pre"))
  (setq *dec* (atoi (get_tile "dec")))
  (setq *tramos* (atof (get_tile "fija")))
  (cond ((= (get_tile "altxt") "")
        (set_tile "error" "Debes indicar altura de texto")
        (mode_tile "altxt" 2)
        )
        ((= (get_tile "dec") "")
        (set_tile "error" "Debes indicar cantidad de decimales")
        (mode_tile "dec" 2)
        )
        ((and (= (get_tile "df") "1") (< *tramos* 1.0))
        (set_tile "error" "Debes indicar Distancia FIJA")
        (mode_tile "fija" 2)
        )
        (t (done_dialog) 1)
  )
)
;;;================================================================================================
(defun inverpol ()
  (foreach item (reverse (entget name))
    (cond ((not hecho)
          (cond ((= (nth 0 item) 40) (setq pie (cons (cons 41 (cdr item)) pie)) (setq hecho t))
                ((= (nth 0 item) 41) (setq pie (cons (cons 40 (cdr item)) pie)))
                ((= (nth 0 item) 42) (setq pie (cons (cons 42 (- (cdr item))) pie)))
                ((= (nth 0 item) 210) (setq pie (cons item pie)))
          )
          )
          ((= (nth 0 item) 10) (setq vert (cons item vert)))
          ((= (nth 0 item) 40) (setq vert (cons (cons 41 (cdr item)) vert)))
          ((= (nth 0 item) 41) (setq vert (cons (cons 40 (cdr item)) vert)))
          ((= (nth 0 item) 42) (setq vert (cons (cons 42 (- (cdr item))) vert)))
          (t (setq jefe (cons item jefe)))
    )
  )
  (setq flag (assoc 70 jefe))
  (if (< (cdr flag) 128)
    (setq jefe (subst (cons 70 (+ (cdr flag) 128)) flag jefe))
  )
  (entmod (append jefe (reverse vert) pie))
)
;;;================================================================================================
 ; Convierte numeros reales en numeros imperiales.
 ; Ejemplo-> (imp 1234.568 2) "1+234.57"
(defun imp (num dec / str a b dz)
  (setq dz (getvar 'dimzin))
  (setvar 'dimzin 0)
  (setq str (rtos num 2 dec))
  (setvar 'dimzin dz)
  (while (< (strlen str)
            (if (= dec 0)
              4
              (+ dec 5)
            )
        )
    (setq str (strcat "0" str))
  )
  (setq a (if (= dec 0)
            (- (strlen str) 2)
            (- (strlen str) dec 3)
          )
  )
  (setq b (substr str 1 (1- a)))
  (setq a (substr str a))
  (strcat b "+" a)
)
;;;================================================================================================
(defun pt_0 ()
  (setq pt0 (trans (vlax-curve-getpointatdist name 0.0) 0 1))
  (setq marca (* (getvar "VIEWSIZE") 0.02))
  (setq p1 (polar pt0 (* pi (/ 90 180.0)) marca))
  (setq p2 (polar pt0 (* pi (/ 234 180.0)) marca))
  (setq p3 (polar pt0 (* pi (/ 18 180.0)) marca))
  (setq p4 (polar pt0 (* pi (/ 162 180.0)) marca))
  (setq p5 (polar pt0 (* pi (/ 306 180.0)) marca))
  (grvecs (list 3 p1 p2 p2 p3 p3 p4 p4 p5 p5 p1))
  (setq p1 (trans (vlax-curve-getpointatdist name 0.01) 0 1))
  (setq ang (angle pt0 p1))
  (if (< inic 1000)
    (setq txt (strcat "0+" (rtos inic 2 *dec*)))
    (setq txt (strcat (itoa (fix (/ inic 1000)))
                      "+"
                      (rtos (- inic (* (fix (/ inic 1000)) 1000)) 2 *dec*)
              )
    )
  )
  (if (> ang pi)
    (setq ang (- ang pi))
  )
  (setq ang (- ang (* pi 0.5)))
  (vl-cmdf "_insert"
          (strcat "MARCA_" mar)
          (trans pt0 0 1)
          *scl*
          *scl*
          (rag ang)
          (strcat *pre* " " txt)
  )
)
;;;================================================================================================
(defun atrib_marca ()
  (entmake (list '(0 . "ATTDEF") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model") '(8 . "0")
                '(100 . "AcDbText") '(10 1.5 -0.5 0.0) '(40 . 1.0) '(1 . "") '(50 . 0.0)
                '(41 . 1.0) '(51 . 0.0) '(7 . "ENCAD") '(71 . 0) '(72 . 0) '(11 1.5 0.0 0.0)
                '(210 0.0 0.0 1.0) '(100 . "AcDbAttributeDefinition") '(3 . "") '(2 . "PUNTO")
                '(70 . 0) '(73 . 0) '(74 . 2)
                )
  )
)
;;;================================================================================================
(defun atrib_tramo ()
  (entmake (list '(0 . "ATTDEF") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model") '(8 . "0")
                '(100 . "AcDbText") '(10 0.0 0.0 0.0) '(40 . 1.0) '(1 . "") '(50 . 0.0) '(41 . 1.0)
                '(51 . 0.0) '(7 . "ENCAD") '(71 . 0) '(72 . 1) '(11 0.0 0.0 0.0) '(210 0.0 0.0 1.0)
                '(100 . "AcDbAttributeDefinition") '(3 . "") '(2 . "TRAMO") '(70 . 0) '(73 . 0)
                '(74 . 1) '(280 . 0)
                )
  )
)
;;;================================================================================================
(defun bloques ()
  (if (not (tblobjname "STYLE" "ENCAD"))
    (entmake (list '(0 . "STYLE") '(100 . "AcDbSymbolTableRecord")
                  '(100 . "AcDbTextStyleTableRecord") '(2 . "ENCAD") '(70 . 0) '(40 . 0.0)
                  '(41 . 1.0) '(50 . 0.0) '(71 . 0) '(3 . "ARIAL") '(4 . "")
                  )
    )
  )
  (setvar "textstyle" "ENCAD")
  (if (not (tblobjname "block" "MARCA_PNT"))
    (progn (entmake '((0 . "BLOCK") (2 . "MARCA_PNT") (70 . 2) (10 0.0 0.0 0.0)))
          (entmake (list '(0 . "POINT") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbPoint")
                          '(10 0.0 0.0 0.0)
                        )
          )
          (atrib_marca)
          (entmake '((0 . "endblk")))
    )
  )
  (if (not (tblobjname "block" "MARCA_TRZ"))
    (progn (entmake '((0 . "BLOCK") (2 . "MARCA_TRZ") (70 . 2) (10 0.0 0.0 0.0)))
          (entmake (list '(0 . "LINE") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model") '(8 . "0")
                          '(100 . "AcDbLine") '(10 -0.5 0.0 0.0) '(11 0.5 0.0 0.0)
                          '(210 0.0 0.0 1.0)
                        )
          )
          (atrib_marca)
          (entmake '((0 . "endblk")))
    )
  )
  (if (not (tblobjname "block" "MARCA_CRL"))
    (progn (entmake '((0 . "BLOCK") (2 . "MARCA_CRL") (70 . 2) (10 0.0 0.0 0.0)))
          (entmake (list '(0 . "CIRCLE") '(8 . "0") '(10 0.0 0.0 0.0) '(40 . 0.5)))
          (atrib_marca)
          (entmake '((0 . "endblk")))
    )
  )
  (if (not (tblobjname "block" "TRAMO"))
    (progn (entmake '((0 . "BLOCK") (2 . "TRAMO") (70 . 2) (10 0.0 0.0 0.0)))
          (atrib_tramo)
          (entmake '((0 . "endblk")))
    )
  )
  (if (not (tblobjname "block" "PUNTO"))
    (progn (entmake '((0 . "BLOCK") (2 . "PUNTO") (70 . 2) (10 0.0 0.0 0.0)))
          (entmake (list '(0 . "POINT") '(100 . "AcDbEntity") '(8 . "0") '(100 . "AcDbPoint")
                          '(10 0.0 0.0 0.0)
                        )
          )
          (entmake '((0 . "endblk")))
    )
  )
) ; defun bloques
;;;================================================================================================
(defun draw_encad ()
  (if (/= opc "it") ;indicar tramos
    (progn (setq ent (entsel "\nDesigna polilínea CERCA de INICIO: "))
          (while (and (/= (cdr (assoc 0 (entget (nth 0 ent)))) "LWPOLYLINE")
                      (/= (cdr (assoc 0 (entget (nth 0 ent)))) "POLYLINE")
                  )
            (alert "Esa entidad no es una polilínea")
            (setq ent (entsel "\nDesigna polilínea CERCA de INICIO: "))
          )
          (setq name (nth 0 ent))
          (setq pt (vlax-curve-getclosestpointto name (nth 1 ent))) ;punto mas cercano al punto
          (setq ent (vlax-ename->vla-object name))
          (setq long (vlax-get ent 'length))
          (setq l1 (vlax-curve-getdistatpoint name pt)) ;longitud inicio a punto
          (setq l2 (- long l1))
          (if (> l1 l2)
            (inverpol)
          )
    )
    (progn (setq ent (entsel "\nDesigna polilínea: "))
          (while (and (/= (cdr (assoc 0 (entget (nth 0 ent)))) "LWPOLYLINE")
                      (/= (cdr (assoc 0 (entget (nth 0 ent)))) "POLYLINE")
                  )
            (alert "Esa entidad no es una polilínea")
            (setq ent (entsel "\nDesigna polilínea: "))
          )
          (setq name (nth 0 ent))
          (setq ent (vlax-ename->vla-object name))
    )
  )
  (cond ((= opc "ip") ; Indicar Puntos
        (setq inic (getreal "\nKilometraje de Inicio <0.00>: "))
        (if (= inic nil)
          (setq inic 0.00)
          (setq inic inic)
        )
        (pt_0)
        (while (setq p0 (getpoint "\nIndica punto: "))
          (setq p0 (vlax-curve-getclosestpointto name p0)) ;punto mas cercano a p0
          (setq dis (vlax-curve-getdistatpoint name (trans p0 1 0))) ;longitud inicio a punto
          (setq p1 (vlax-curve-getpointatdist name (+ dis 0.01))) ;punto desde inicio
          (setq ang (angle p0 (trans p1 0 1)))
          (setq txt (imp (+ dis inic) *dec*)) ;imperial
          ;;(setq txt (rtos (+ dis inic) 2 *dec*));decimal
          (if (> ang pi)
            (setq ang (- ang pi))
          )
          (setq ang (- ang (* pi 0.5)))
          (vl-cmdf "_insert" (strcat "MARCA_" mar) p0 *scl* *scl* (rag ang) (strcat *pre* " " txt))
        )
        )
        ((= opc "id") ; Indicar Distancias
        (setq inic (getreal "\nKilometraje de Inicio <0.00>: "))
        (if (= inic nil)
          (setq inic 0.00)
          (setq inic inic)
        )
        (pt_0)
        (while (setq dis (getreal "\nEscribe Distancia desde Contador: "))
          (if (= dis "")
            (exit)
          )
          (setq p0 (vlax-curve-getpointatdist name dis)) ;punto desde inicio
          (setq p1 (vlax-curve-getpointatdist name (+ dis 0.01))) ;punto desde inicio + 0.01
          (setq ang (angle p0 (trans p1 0 1)))
          (setq txt (imp (+ dis inic) *dec*)) ;imperial
          ;;(setq txt (rtos (+ dis inic) 2 *dec*));decimal
          (if (> ang pi)
            (setq ang (- ang pi))
          )
          (setq ang (- ang (* pi 0.5)))
          (vl-cmdf "_insert" (strcat "MARCA_" mar) p0 *scl* *scl* (rag ang) (strcat *pre* " " txt))
        )
        )
        ((= opc "it") ; Indicar Tramos
        (while (setq p1 (getpoint "\nIndica Primer punto: "))
          (if (= p1 nil)
            (exit)
          )
          (setq p1 (vlax-curve-getclosestpointto name p1)) ;punto mas cercano a p1
          (vl-cmdf "_insert" "PUNTO" p1 *scl* *scl* 0)
          (setq p2 (getpoint "\nIndica Segundo punto: "))
          (if (= p2 nil)
            (exit)
          )
          (setq p2 (vlax-curve-getclosestpointto name p2)) ;punto mas cercano a p2
          (vl-cmdf "_insert" "PUNTO" p2 *scl* *scl* 0)
          (setq lp1 (vlax-curve-getdistatpoint name (trans p1 1 0))) ;longitud inicio a punto p1
          (setq lp2 (vlax-curve-getdistatpoint name (trans p2 1 0))) ;longitud inicio a punto p2
          (setq dim (abs (- lp1 lp2))) ;75.2041
          (setvar 'osmode 512)
          (setq p0 (getpoint "\nIndicar posición para distancia: "))
          (setvar 'osmode 0)
          (setq dis (vlax-curve-getdistatpoint name (trans p0 1 0))) ;longitud inicio a punto p0
          (setq p1 (trans (vlax-curve-getpointatdist name (+ dis 0.01)) 0 1)) ;desde inicio +0.01
          (setq ang (angle p0 p1))
          (setq txt (rtos dim 2 *dec*))
          (if (and (> ang (* pi 0.5)) (< ang (* pi 1.5)))
            (setq ang (+ ang pi))
          )
          (vl-cmdf "_insert" "TRAMO" p0 *scl* *scl* (rag ang) (strcat *pre* " " txt))
        )
        )
        ((= opc "df") ; Distancia Fija
        (setq inic (getreal "\nKilometraje de Inicio <0.00>: "))
        (if (= inic nil)
          (setq inic 0.00)
        )
        (pt_0)
        (setq paso *tramos*)
        (while (setq p0 (vlax-curve-getpointatdist name paso))
          (setq p1 (vlax-curve-getpointatdist name (+ paso 0.01)))
          (setq ang (angle p0 p1))
          (if (> ang pi)
            (setq ang (- ang pi))
          )
          (setq ang (- ang (* pi 0.5)))
          (setq dis (vlax-curve-getdistatpoint name (trans p0 1 0)))
          (setq txt (imp (+ dis inic) *dec*))
          (vl-cmdf "_insert" (strcat "MARCA_" mar) p0 *scl* *scl* (rag ang) (strcat *pre* " " txt))
          (setq paso (+ paso *tramos*))
        )
        )
  )
) ; defun draw_encad
;;;================================================================================================
(defun c:dtencad (/ stl file indi opc pie hecho vert jefe flag pt0 marca p1 p2 p3 p4 p5 ang txt ent
                  name pt long l1 l2 inic p0 dis lp1 lp2 dim paso mar icon pdm
                )
  (vl-load-com)
  (vla-startundomark (vlax-get-property (vlax-get-acad-object) 'activedocument))
  (setq stl (getvar "textstyle"))
  (setq icon (getvar 'ucsicon))
  (setq pdm (getvar 'pdmode))
  (vl-cmdf "_ucs" "_w")
  (mapcar 'setvar (list 'ucsicon 'cmdecho 'orthomode 'attmode 'attreq 'insunits) (list 2 0 0 1 1 4))
  (dialog_encad)
  (setq indi (load_dialog file))
  (new_dialog "temp" indi)
  (cuadro_encad)
  (vl-file-delete file)
  (start_dialog)
  (bloques)
  (draw_encad)
  (unload_dialog indi)
  (setvar 'textstyle stl)
  (setvar 'ucsicon icon)
  (vl-cmdf "_ucs" "_p")
  (redraw)
  (vla-endundomark (vlax-get-property (vlax-get-acad-object) 'activedocument))
  (prin1)
)
;;;================================================================================================

Saludos

Uhmmmm. La probaremos. Gracias!!!!

Maestro al aplicar el lisp me da el siguiente mensaje:
Comando: DTENCAD ; error: tipo de argumento erróneo: stringp nil

Creo que da error en algunas opciones, en versiones anteriores funcionaba bien, lo estudiare, haber si tengo algo de tiempo.

Luis Alberto Benitez escribió:Maestro al aplicar el lisp me da el siguiente mensaje:
Comando: DTENCAD ; error: tipo de argumento erróneo: stringp nil

Ya esta corregida la rutina DTencad.lsp Podeis bajarla del inicio del post.
saludos

Gracias Maestro Funciona de una.