CODIGO FUENTE

Hola foreros:
Debido a mi edad (74 años) y a algun problema de salud familiar, he decidido retirarme de este mundo tan fascinante de AutoLISP/VisuaLISP, que me a llevado a crear multitud de rutinas y aplicaciones para mi vida de profesional de diseño de maquinas y utillajes para la industria del automovil durante 35 largos años.

Empece a interesarme por Autolisp en el año 1989 con la version 10 de Autocad, y ha sido un no parar.

No he ido a ninguna escuela a aprender, (solo algun libro que iba encontrando) y a lo aprendido en este foro asi
como en el antiguo HISPACAD desde el año 2005.

Hasta ahora me he ido reservando algun codigo fuente, ya que es muy ingrato crear y crear, para luego tener que
regalar tantas horas de insomnio, pero como no deseo que se pierda todo lo que he creado y aprendido, pues he decidido que cualquier rutina de mi propiedad compilada que a alguien le interese, puede pedirla aqui o por privado,
"luisfuentef@gmail.com" y yo gustosamente la pondre en codigo fuente (Fichero.LSP).

La unica aplicacion que no puedo compartir por motivos obvios, es la de proteccion de rutinas, ya que si aqui
descubriera el secreto, todo el mundo sabria las claves de licencia para hacer funcionar las rutinas protegidas.

Un saludo y hasta siempre.

Domínguez, ha sido un gran placer contar con tu apoyo para infinidad de aplicaciones!!!! Yo, al igual que tú, también le debo muchísimo a los foros. Yo empecé en el 3dgazpacho, hace ya varios lustros. Después me pasé a Hispacad y ahora por estos lares andamos.
Agradecerte infinitamente tus horas dedicadas a enseñar y facilitar las cosas a los demás. Qué gran invento esto del LISP!!!
74 años no son nada!!!! Yo, a ver si llego, que tengo 20 menos y estoy que me duelen todos los huesos como si me mantearan todos los días. jajajaja. En fin, lo dicho, mucha suerte. Y aunque no te pases todos los días por el foro, de vez en cuando aún te entretienes y nos haces alguna visita. SUERTEEEE!!!!!!!! y GRACIASSSSSSS!!!!!!

Por supuesto que estare al tanto de lo que sucede en el foro, pero no creo que tenga tiempo para colaborar, pero bueno dejo una puerta abierta.

Ni que decir Maestro Domínguez. Muchas gracias por compartir tu experiencia, ayudar a los que en algún momento incursionamos en este apasionante mudo del lisp. Sin duda alguna, unos de los pilares del extinto hispacad y obviamente de este foro también. Deseo de corazón que se arrglen tus dolencias y que de vez en cuando te asomes a ver como vamos.

Mucha suerte y otra vez, Gracias.

Buena suerte maestro. Ha sido un placer seguir tus códigos.
Gracias por todo.

Lo que quise decir, es que las aplicaciones que algun dia subi a este foro compiladas VLX, puedo ponerlas en codigo LSP, para quien lo pida.
Un saludo

Yo agradecería la de coordenadas DDcuadro_Coord4.VLX y DDarear.VLX
Gracias!!!

El Lunes las tendras.

robierzo escribió:Yo agradecería la de coordenadas DDcuadro_Coord4.VLX y DDarear.VLX
Gracias!!!

El lunes cuando venda de viaje te las pondre.

robierzo escribió:Yo agradecería la de coordenadas DDcuadro_Coord4.VLX y DDarear.VLX
Gracias!!!

DTcuadro_Coord.lsp

Código:

; Crea tabla de coordenadas (UCS Universal) de PUNTOS, POL2D, POL3D.
 ; Con o sin Tabla y ficheros TXT o CSV.
 ; Luis Dominguez Gomez :copyright: 2016
;;;================================================================================================
(defun dialogo_dtcc ()
  (setq fil (vl-filename-mktemp "dcl.dcl"))
  (setq ind (open fil "W"))
  (foreach str
           (list
             "temp:dialog{key="rotulo";" ;
             "  spacer;" ;
             "  :row{" ;
             "    :boxed_column{label=" DATOS ";"
             "      :edit_box{label="Altura de texto";key="altxt";edit_width=3;fixed_width_font=true;allow_accept=true;}"
             "      :edit_box{label="Nº de Decimales";key="dec";edit_width=0.5;edit_limit=1;alignment=centered;fixed_width_font=true;allow_accept=true;}"
             "      :edit_box{label="Número inicial";key="inic";edit_width=3;fixed_width_font=true;allow_accept=true;}"
             "      :edit_box{label="Prefijo de Puntos";key="pre";edit_width=3;fixed_width_font=true;allow_accept=true;}"
             "    }" ;
             "    :boxed_column{label=" SELECCIÓN ";"
             "      :radio_button{label="Puntos";key="pp";}"
             "      :radio_button{label="Polilinea2D";key="p2d";}"
             "      :radio_button{label="Polilinea3D";key="p3d";}"
             "      :toggle{label="Cota-Z";key="zeta";}"
             "      :toggle{label="Tabla";key="tab";}" ;
             "    }" ;
             "    :boxed_column{label=" ARCHIVO ";" ;
             "      :radio_button{label="GSI";key="gsi";}"
             "      :radio_button{label="TXT";key="txt";}"
             "      :radio_button{label="CSV";key="csv";}" ;
             "    }" ;
             "  }" ;
             "  :boxed_column{label=" INDICACIONES ";"
             "    :errtile{fixed_width_font=true;alignment=centered;}" ;
             "  }" ;
             "  :row{" ;
             "    :image{key="foto";width=10;color=dialog_background;}" ;
             "    :column{" ;
             "      ok_cancel_help;" ;
             "      :boxed_column{label=" Luis Dominguez Gómez  :copyright: 2022 ";"
             "        :text{key="fecha";alignment=centered;}" ;
             "      }" ;
             "    }" ;
             "    :image{key="marca";width=8;color=dialog_background;}" ;
             "  }" ;
             "  :text{label="l u i s f u e n t e f @ g m a i l . c o m";alignment=centered;}" ;
             "}" ;
             "help_coor_dtcc:dialog{key="rotulo2";"
             "  :list_box{key="lista";height=20;width=100;fixed_width_font=true;}" ;
             "  :row{" ;
             "    :boxed_column{label="Autor y propietario";"
             "      :text{key="rotulo3";fixed_width_font=true;alignment=centered;is_enabled=false;}"
             "    }" ;
             "    spacer;" ;
             "    ok_only;" ;
             "  }" ;
             "}"
            )
    (write-line str ind)
  )
  (close ind)
)
;;;================================================================================================
(defun cuadro_dtcc ()
  (set_tile "rotulo" (strcat " CUADRO  de  COORDENADAS  :copyright:" (substr (rtos (getvar 'cdate) 2 4) 1 4)))
  (marca_ldg)
  (foto_ldg 65 0) ;V-H
  (if *scl*
    (set_tile "altxt" (rtos *scl* 2 2))
    (set_tile "altxt" (rtos (getvar 'textsize) 2 2))
  )
  (if *dec*
    (set_tile "dec" (itoa *dec*))
    (set_tile "dec" "3")
  )
  (if *inic*
    (set_tile "inic" (itoa *inic*))
    (set_tile "inic" "1")
  )
  (if *pre*
    (set_tile "pre" *pre*)
    (set_tile "pre" "P")
  )
  (mapcar 'set_tile '("gsi" "txt" "csv") '("0" "0" "0"))
  (mapcar 'action_tile
          '("accept" "pp" "p2d" "p3d" "cancel" "help")
          '("(ok_coor_dtcc)" "(mode_tile "zeta" 0)(set_tile "zeta" "0")"
            "(mode_tile "zeta" 1)(set_tile "zeta" "0")"
            "(mode_tile "zeta" 1) (set_tile "zeta" "1")" "(exit)" "(ayuda_cuadro_dtcc)"
           )
  )
  (set_tile "fecha" (menucmd "M=$(edtime, $(getvar,date),DDDD"" DD MONTH YYYY - HH:MM am/pm)"))
)
;;;================================================================================================
(defun entorno_tabla_dtcc nil
  (if (not (tblobjname "STYLE" "TABLA"))
    (entmake (list '(0 . "STYLE") '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbTextStyleTableRecord") '(2 . "TABLA") '(70 . 0) '(40 . 0.0)
                   '(41 . 1.0) '(50 . 0.0) '(71 . 0) '(3 . "Consolas") '(4 . "")
                  )
    )
  )
  (setvar 'textstyle "TABLA")
  (if (not (tblobjname "LAYER" "TABLA_PTOS"))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   '(2 . "TABLA_PTOS") '(70 . 0) '(62 . 8) '(6 . "CONTINUOUS")
                  )
    )
  )
  (setvar 'clayer "TABLA_PTOS")
)
;;;================================================================================================
(defun ayuda_cuadro_dtcc ()
  (new_dialog "help_coor_dtcc" ind)
  (action_tile "accept" "(done_dialog)")
  (start_list "lista")
  (mapcar
    'add_list
    (list
      "· La Altura de texto es obligatoria, se puede cambiar." ;
      "  (Al inicio, se impone la altura por defecto actual.)" ;
      "  (recuerda cada vez la ultima altura usada.)" ;
      "· La precisión decimal es obligatoria, se puede cambiar." ;
      "  (Al inicio, se impone 3 decimales.)" ;
      "  (recuerda cada vez la ultima precisión usada.)" ;
      "· El número inicial se puede cambiar." ;
      "  (Al inicio, se impone número 1.)" ;
      "  (Propone cada vez número siguiente al ultimo usado.)" ;
      "· El prefijo no es obligatorio." ;
      "  (Texto que va delante del numero de orden.)" ;
      "  (Si existe, siempre se puede cambiar. si no existe, propone P.)" ;
      "· Puntos, es la opcion de indicar puntos en el dibujo para poner sus coordenadas en tabla."
      "· Poli2D, es la opcion de indicar poli2D para poner coordenadas XY de los vertices en tabla."
      "· Poli3D, es la opcion de indicar poli3D para poner coordenadas XYZ de los vertices en tabla."
      "· Cota Z, es la opcion para poner en tabla, coordenadas Z de los puntos indicados." ;
      "· Fichero SI, Propone tres formatos de reporte ademas de la tabla en el dibujo." ;
     )
  )
  (end_list)
  (action_tile "accept" "(done_dialog 1)")
  (start_dialog)
)
;;;================================================================================================
(defun blk_punto_dtcc ()
  (if (not (tblobjname "BLOCK" "PUNTO_TBL"))
    (foreach h (list (list '(0 . "BLOCK") '(100 . "AcDbEntity") '(67 . 0) '(8 . "TABLA_PTOS")
                           '(100 . "AcDbBlockBegin") '(1 . "PUNTO_TBL") '(2 . "PUNTO_TBL") '(70 . 2)
                           '(10 0.0 0.0 0.0)
                          )
                     (list '(0 . "LINE") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model")
                           '(8 . "TABLA_PTOS") '(62 . 1) '(100 . "AcDbLine") '(10 -0.5 0.0 0.0)
                           '(11 0.5 0.0 0.0) '(210 0.0 0.0 1.0)
                          )
                     (list '(0 . "LINE") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model")
                           '(8 . "TABLA_PTOS") '(62 . 1) '(100 . "AcDbLine") '(10 0.0 0.5 0.0)
                           '(11 0.0 -0.5 0.0) '(210 0.0 0.0 1.0)
                          )
                     (list '(0 . "ATTDEF") '(100 . "AcDbEntity") '(67 . 0) '(410 . "Model")
                           '(8 . "TABLA_PTOS") '(62 . 1) '(100 . "AcDbText") '(10 -1.47619 1.5 0.0)
                           '(40 . 1.0) '(1 . "") '(50 . 0.0) '(41 . 1.0) '(51 . 0.0) '(7 . "TABLA")
                           '(71 . 0) '(72 . 1) '(11 9.18455e-017 1.5 0.0) '(210 0.0 0.0 1.0)
                           '(100 . "AcDbAttributeDefinition") '(3 . "PUNTO") '(2 . "PUNTO")
                           '(70 . 0) '(72 . 1) '(73 . 0) '(74 . 0) '(280 . 0)
                          )
                     (list '(0 . "ENDBLK"))
               )
      (entmake h)
    )
  )
)
;;;================================================================================================
(defun crea_tabla_dtcc ()
  (setvar 'luprec *dec*)
  (setq acm (vla-getinterfaceobject (vlax-get-acad-object)
                                    (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))
            )
  )
  (setq tabla (vla-addtable ;crea tabla
                (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
                (vlax-3d-point (setq punto (getpoint "\nPunto Inserción Tabla: ")))
                2 ;rows
                col ;columnas
                *scl* ;altura texto
                *scl* ;altura texto
              )
  )
  (vla-put-titlesuppressed tabla :vlax-false) ;activa titulo
  (vla-put-headersuppressed tabla :vlax-false) ;activa cabecera
  (vla-put-regeneratetablesuppressed tabla :vlax-true) ;regenerar/suprimirla
  (vla-put-vertcellmargin tabla (* *scl* 0.25)) ;margen vertical
  (vla-put-horzcellmargin tabla (* *scl* 0.25)) ;margen horizontal
  (vla-setrowheight tabla 0 *scl*) ;altura row 1
  (vla-setrowheight tabla 1 *scl*) ;altura row 2
  (vla-setcolumnwidth tabla 0 (* *scl* 8)) ; ancho columna 1
  (vla-setcolumnwidth tabla 1 (* *scl* 12)) ; ancho columna 2
  (vla-setcolumnwidth tabla 2 (* *scl* 12)) ; ancho columna 3
  (vla-settextstyle tabla actitlerow "TABLA") ;Estilo texto titulo
  (vla-settextstyle tabla acheaderrow "TABLA") ;Estilo texto cabecera
  (vla-settextstyle tabla acdatarow "TABLA") ;Estilo texto celdas
  (vla-settextheight tabla actitlerow (* *scl* 1.25)) ;altura texto titulo
  (vla-settextheight tabla acheaderrow *scl*) ;altura texto cabecera
  (vla-settextheight tabla acdatarow *scl*) ;altura texto celdas
  (vla-setalignment tabla actitlerow acmiddlecenter) ;alineacion titulo
  (vla-setalignment tabla acheaderrow acmiddlecenter) ;alineacion cabecera
  (vla-setalignment tabla acdatarow acmiddleright) ;alinacion datos
  (vla-settext tabla 1 0 (strcase h nil)) ;columna-1
  (vla-settext tabla 1 1 "COORDENADA-X") ;columna-2
  (vla-settext tabla 1 2 "COORDENADA-Y") ;columna-3
  (vla-put-colorindex acm 7) ;blanco
  (vla-setcellcontentcolor tabla 0 0 acm)
  (vla-setcellcontentcolor tabla 1 0 acm)
  (vla-put-colorindex acm 1) ;rojo
  (vla-setcellcontentcolor tabla 1 1 acm)
  (vla-put-colorindex acm 2) ;amarillo
  (vla-setcellcontentcolor tabla 1 2 acm)
  (if (= col 4)
    (progn (vla-setcolumnwidth tabla 3 (* *scl* 12))
           (vla-settext tabla 1 3 "COORDENADA-Z")
           (vla-put-colorindex acm 3) ;verde
           (vla-setcellcontentcolor tabla 1 3 acm)
    )
  )
  (vla-put-regeneratetablesuppressed tabla :vlax-false) ;regenera tabla
)
;;;================================================================================================
(defun ok_coor_dtcc ()
  (setq *scl* (atof (get_tile "altxt")))
  (setq *inic* (atoi (get_tile "inic")))
  (setq *pre* (strcase (get_tile "pre")))
  (setq *dec* (atoi (get_tile "dec")))
  (setq zeta (get_tile "zeta"))
  (if (= zeta "1")
    (progn (setq niv "3D") (setq col 4))
    (progn (setq niv "2D") (setq col 3))
  )
  (setq pp (get_tile "pp"))
  (setq p2d (get_tile "p2d"))
  (setq p3d (get_tile "p3d"))
  (setq tab (get_tile "tab"))
  (setq gsi (get_tile "gsi"))
  (setq txt (get_tile "txt"))
  (setq csv (get_tile "csv"))
  (if (or (= p2d "1") (= p3d "1"))
    (setq h "VERTICES")
    (setq h "PUNTOS")
  )
  (cond ((= (get_tile "altxt") "")
         (set_tile "error" "Debes indicar ALTURA de TEXTOS")
         (mode_tile "altxt" 2)
        )
        ((= (get_tile "dec") "") (set_tile "error" "Debes indicar DECIMALES") (mode_tile "dec" 2))
        ((= (get_tile "inic") "")
         (set_tile "error" "Debes indicar NUMERO INICIAL")
         (mode_tile "inic" 2)
        )
        ((and (= (get_tile "pp") "0") (= (get_tile "p2d") "0") (= (get_tile "p3d") "0"))
         (set_tile "error" "Debes indicar SELECCIÓN")
        )
        ((and (= tab "0") (= gsi "0") (= txt "0") (= csv "0"))
         (set_tile "error" "Debes indicar TABLA - ARCHIVO - o AMBOS")
        )
        (t (done_dialog) 1)
  )
)
;;;================================================================================================
(defun puntos_dtcc ()
  (setq num (strcat *pre* (itoa *inic*)))
  (if (/= pto nil)
    (progn (vl-cmdf "_insert" "PUNTO_TBL" pto *scl* *scl* 0 num)
           (setq blk (vlax-ename->vla-object (entlast)))
           (setq x (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                           (itoa (vla-get-objectid blk))
                           ">%).InsertionPoint \\f "%lu2%pt1">%"
                   )
           )
           (setq y (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                           (itoa (vla-get-objectid blk))
                           ">%).InsertionPoint \\f "%lu2%pt2">%"
                   )
           )
           (if (= zeta "1")
             (setq z (strcat "%<\\AcObjProp Object(%<\\_ObjId "
                             (itoa (vla-get-objectid blk))
                             ">%).InsertionPoint \\f "%lu2%pt4">%"
                     )
             )
           )
           (setq *inic* (1+ *inic*))
    )
  )
)
;;;================================================================================================
(defun titulo_dtcc (_a _b _c)
  (vla-settext tabla
               0
               0
               (strcat "TABLA de " (strcase _a nil) "-" _b " (" inic "-" (itoa (1- *inic*)) ")" _c)
  )
)
;;;================================================================================================
(defun ptpt_dtcc ()
  (if (= gsi "1")
    (archivo_dtcc h ".txt")
  )
  (if (= txt "1")
    (archivo_dtcc h ".txt")
  )
  (if (= csv "1")
    (archivo_dtcc h ".csv")
  )
  (while (setq pto (getpoint (strcat "\nIndicar Punto: <" (itoa *inic*) ">")))
    (puntos_dtcc)
    (if (= tab "1")
      (progn (insert_row_dtcc) (titulo_dtcc h niv ""))
    )
    (if (= gsi "1")
      (file_gsi_dtcc)
    )
    (if (= txt "1")
      (file_txt_dtcc)
    )
    (if (= csv "1")
      (file_csv_dtcc)
    )
  )
)
;;;================================================================================================
(defun pol2d_dtcc ()
  (if (= gsi "1")
    (archivo_dtcc h ".txt")
  )
  (if (= txt "1")
    (archivo_dtcc h ".txt")
  )
  (if (= csv "1")
    (archivo_dtcc h ".csv")
  )
  (setq pl (cdr (entget (nth 0 (entsel "\nSelecciona Polilinea2D: ")))))
  (while pl
    (cond ((= (caar pl) 10)
           (setq pto (cdr (nth 0 pl)))
           (puntos_dtcc)
           (if (= gsi "1")
             (file_gsi_dtcc)
           )
           (if (= txt "1")
             (file_txt_dtcc)
           )
           (if (= csv "1")
             (file_csv_dtcc)
           )
           (if (= tab "1")
             (progn (insert_row_dtcc) (titulo_dtcc h "Pol2D" ""))
           )
          )
    )
    (setq pl (cdr pl))
  )
)
;;;================================================================================================
(defun pol3d_dtcc ()
  (if (= gsi "1")
    (archivo_dtcc h ".txt")
  )
  (if (= txt "1")
    (archivo_dtcc h ".txt")
  )
  (if (= csv "1")
    (archivo_dtcc h ".csv")
  )
  (setq
    pl (entget (entnext (cdr (assoc -1 (entget (nth 0 (entsel "\nSelecciona Polilinea3D: ")))))))
  )
  (while (not (assoc -2 pl))
    (setq pto (cdr (assoc 10 pl)))
    (puntos_dtcc)
    (if (= gsi "1")
      (file_gsi_dtcc)
    )
    (if (= txt "1")
      (file_txt_dtcc)
    )
    (if (= csv "1")
      (file_csv_dtcc)
    )
    (if (= tab "1")
      (progn (insert_row_dtcc) (titulo_dtcc h "Pol3D" ""))
    )
    (setq pl (entget (entnext (cdr (assoc -1 pl)))))
  )
)
;;;================================================================================================
(defun file_csv_dtcc ()
  (setq ind (open arch "a"))
  ;;·············································································
  (if (= pp "1")
    (if (= zeta "1")
      (progn (princ (strcat (itoa (1- *inic*)) ;punto
                            ";"
                            (rtos (nth 0 pto) 2 *dec*) ;este X
                            ";"
                            (rtos (nth 1 pto) 2 *dec*) ;norte Y
                            ";"
                            (rtos (nth 2 pto) 2 *dec*) ;cota Z
                            "\n"
                    )
                    ind
             )
      )
      (progn (princ (strcat (itoa (1- *inic*)) ;punto
                            ";"
                            (rtos (nth 0 pto) 2 *dec*) ;este X
                            ";"
                            (rtos (nth 1 pto) 2 *dec*) ;norte Y
                            "\n"
                    )
                    ind
             )
      )
    )
  )
  ;;·············································································
  (if (= p2d "1")
    (princ (strcat (itoa (1- *inic*)) ;punto
                   ";"
                   (rtos (nth 0 pto) 2 *dec*) ;este X
                   ";"
                   (rtos (nth 1 pto) 2 *dec*) ;norte Y
                   "\n"
           )
           ind
    )
  )
  ;;·············································································
  (if (= p3d "1")
    (progn (princ (strcat (itoa (1- *inic*)) ;punto
                          ";"
                          (rtos (nth 0 pto) 2 *dec*) ;este X
                          ";"
                          (rtos (nth 1 pto) 2 *dec*) ;norte Y
                          ";"
                          (rtos (nth 2 pto) 2 *dec*) ;cota Z
                          "\n"
                  )
                  ind
           )
    )
  )
  ;;·············································································
  (close ind)
)
;;;================================================================================================
(defun file_txt_dtcc ()
  (setq ind (open arch "a"))
  (write-line (strcat *pre*
                      (itoa (1- *inic*))
                      " "
                      (rtos (nth 0 pto) 2 *dec*)
                      ","
                      (rtos (nth 1 pto) 2 *dec*)
                      (if (= zeta "1")
                        (strcat "," (rtos (nth 2 pto) 2 *dec*))
                        ""
                      )
              )
              ind
  )
  (close ind)
)
;;;================================================================================================
(defun file_gsi_dtcc ()
  (setq ind (open arch "a"))
  (write-line
    (strcat *pre*
            (itoa (1- *inic*))
            " "
            "110001+"
            (substr (rtos (+ 100000000.0 (1- *inic*)) 2 0) 2)
            " 81...0+"
            (substr (rtos (+ 100000000.0 (* (nth 0 pto) 1000.0)) 2 0) 2)
            " 82...0+"
            (substr (rtos (+ 100000000.0 (* (nth 1 pto) 1000.0)) 2 0) 2)
            (if (= zeta "1")
              (strcat " 83...0+" (substr (rtos (+ 100000000.0 (* (nth 2 pto) 1000.0)) 2 0) 2))
              ""
            )
    )
    ind
  )
  (close ind)
)
;;;================================================================================================
(defun archivo_dtcc (p ext)
  (setq arch (strcat (getvar 'dwgprefix) (getstring "\nNombre del archivo: [Sin extension] ") ext))
  (setq ind (open arch "w"))
  (if (= csv "1")
    (if (= zeta "1")
      (write-line "PTOS;ESTE;NORTE;COTA" ind)
      (write-line "PTOS;ESTE;NORTE" ind)
    )
  )
  (close ind)
  (alert "El archivo se creará \nEn el directorio actual ")
)
;;;================================================================================================
(defun insert_row_dtcc ()
  (vla-insertrows tabla cont 1 1) ;insertamos fila
  (vla-settextstyle tabla acdatarow "TABLA") ;estilo texto
  (vla-settextheight tabla acdatarow *scl*) ;altura texto celdas
  (vla-setalignment tabla acdatarow acmiddleright) ;alineacion derecha
  (vla-setrowheight tabla cont 1) ;altura fila
  (vla-settext tabla cont 0 num) ;punto
  (vla-settext tabla cont 1 x) ;coor X
  (vla-settext tabla cont 2 y) ;coor Y
  (vla-put-colorindex acm 7) ;blanco
  (vla-setcellcontentcolor tabla cont 0 acm)
  (vla-put-colorindex acm 1) ;rojo
  (vla-setcellcontentcolor tabla cont 1 acm)
  (vla-put-colorindex acm 2) ;amarillo
  (vla-setcellcontentcolor tabla cont 2 acm)
  (if (= zeta "1")
    (progn (vla-settext tabla cont 3 z) ;coor Z
           (vla-put-colorindex acm 3) ;verde
           (vla-setcellcontentcolor tabla cont 3 acm)
    )
  )
  (setq cont (1+ cont))
)
;;;================================================================================================
(defun draw_coor_dtcc ()
  (setq inic (itoa *inic*))
  (cond ((= pp "1") (ptpt_dtcc))
        ((= p2d "1") (pol2d_dtcc))
        ((= p3d "1") (pol3d_dtcc))
  )
)
;;;================================================================================================
(defun c:dtcc (/ cont ind fil acm tabla zeta pp p2d p3d gsi txt csv col num x y z pto arch pl inic
               punto h blk foto_ldg marca_ldg tab niv
              )
  (vl-load-com)
  (mapcar 'setvar (list 'cmdecho 'attdia 'attmode 'attreq) (list 0 0 2 1))
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (vl-cmdf "_ucs" "_w")
  (setq cont 2)
  (if (not *scl*)
    (setq *scl* (getvar 'textsize))
  )
  (dialogo_dtcc)
  (setq ind (load_dialog fil))
  (new_dialog "temp" ind)
  (if (not marca_ldg)
    (load "marca_ldg")
  )
  (if (not foto_ldg)
    (load "foto_ldg")
  )
  (cuadro_dtcc)
  (vl-file-delete fil)
  (start_dialog)
  (unload_dialog ind)
  (entorno_tabla_dtcc)
  (blk_punto_dtcc)
  (if (= tab "1")
    (crea_tabla_dtcc)
  )
  (draw_coor_dtcc)
  (setvar 'orthomode 0)
  (if tabla
    (vl-cmdf "_move" (vlax-vla-object->ename tabla) "" punto "")
  )
  (vl-cmdf "_ucs" "_pr")
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (prin1)
)
;;;================================================================================================
(alert "Ejecutar con DTCC")

Marca_ldg

Código:

 ; Icono LDG para insertar en cuadros de dialogo.
;;;================================================================================================
(defun marca_ldg ()
  (defun dim (n) (fix (* (dimx_tile "marca") n)))
  (defun vector (a b c d) (vector_image (dim a) (dim b) (dim c) (dim d) 1))
  (start_image "marca")
  (fill_image 0 0 (dimx_tile "marca") (dimy_tile "marca") -2)
  (mapcar 'vector
          '(0.427 0.427 0.844 0.844 0.573 0.427 0.573 0.427 0.427 0.573 0.427 0.219 0.219 0.365
            0.365 0.365 0.365 0.573 0.698 0.757 0.782 0.573 0.615 0.630 0.636 0.636 0.630 0.615
            0.573 0.782 0.757 0.698 0.573 0.093 0.034 0.010 0.010 0.034 0.093 0.219 0.219 0.177
            0.162 0.156 0.156 0.162 0.177 0.365 0.365 0.365 0.365 0.281 0.281 0.427 0.782 0.907
            0.966 0.990 0.990 0.844 0.844 0.838 0.824 0.573 0.990 0.990 0.966 0.907 0.573 0.823
            0.838 0.844 0.844 0.838 0.824
          )
          '(0.740 0.990 0.990 0.928 0.928 0.323 0.323 0.260 0.010 0.010 0.886 0.886 0.114 0.824
            0.531 0.469 0.177 0.114 0.114 0.139 0.198 0.177 0.177 0.183 0.198 0.802 0.817 0.824
            0.824 0.803 0.862 0.886 0.886 0.740 0.716 0.657 0.344 0.285 0.260 0.260 0.678 0.678
            0.671 0.657 0.344 0.329 0.323 0.260 0.323 0.740 0.678 0.531 0.469 0.469 0.260 0.260
            0.285 0.344 0.406 0.406 0.344 0.329 0.323 0.469 0.469 0.657 0.716 0.740 0.531 0.531
            0.538 0.553 0.657 0.671 0.678
          )
          '(0.427 0.844 0.844 0.573 0.573 0.427 0.573 0.427 0.573 0.573 0.219 0.219 0.427 0.427
            0.365 0.365 0.427 0.698 0.757 0.782 0.782 0.615 0.630 0.636 0.636 0.636 0.636 0.630
            0.615 0.782 0.782 0.757 0.698 0.219 0.093 0.034 0.010 0.010 0.034 0.093 0.177 0.162
            0.156 0.156 0.162 0.177 0.219 0.636 0.636 0.636 0.636 0.427 0.281 0.281 0.907 0.966
            0.990 0.990 0.844 0.844 0.838 0.824 0.782 0.990 0.990 0.966 0.907 0.782 0.823 0.838
            0.844 0.844 0.838 0.824 0.782
          )
          '(0.990 0.990 0.928 0.928 0.740 0.678 0.678 0.010 0.010 0.260 0.886 0.114 0.114 0.824
            0.824 0.177 0.177 0.114 0.139 0.198 0.469 0.177 0.183 0.198 0.469 0.531 0.802 0.817
            0.824 0.531 0.803 0.862 0.886 0.740 0.740 0.716 0.657 0.344 0.285 0.260 0.678 0.671
            0.657 0.344 0.329 0.323 0.323 0.260 0.323 0.740 0.678 0.531 0.531 0.469 0.260 0.285
            0.344 0.406 0.406 0.344 0.329 0.323 0.323 0.469 0.657 0.716 0.740 0.740 0.531 0.538
            0.553 0.657 0.671 0.678 0.678
          )
  )
  (end_image)
)
;;;================================================================================================


Foto_ldg

Código:

 ; Imagen L D G    para insertar en cuadros de dialogo.
;;;================================================================================================
(defun foto_ldg (v h / verti horiz)
  (setq verti v)
  (setq horiz h)
  (start_image "foto")
  (foreach x '((108 108 250 250 250 250 250 250 250 250 250 168 179 177 177 177 177 177 177 156 166
                156 166 156 177 177 156 177 179 177 251 189 169 179 166 166 169 169 169 158 168 250
                250 250 248 250 250 250
              )
              (88 250 250 250 250 250 250 250 250 250 250 168 169 169 166 166 166 177 177 156 166
                156 166 156 177 177 156 177 179 187 8 199 179 179 179 158 179 169 169 177 179 168
                250 28 250 250 250 250
              )
              (250 250 250 250 250 250 250 250 250 250 250 168 159 179 166 166 166 166 156 166 166
                166 177 177 177 177 177 169 179 251 251 251 199 179 179 179 158 169 179 159 149 178
                250 250 250 250 250 250
              )
              (250 250 250 250 250 250 250 250 250 250 168 168 159 158 166 166 166 166 166 166 166
                166 177 166 177 177 177 179 251 8 251 251 251 209 159 169 179 179 168 169 163 178
                250 250 250 250 250 250
              )
              (250 250 250 250 250 250 250 250 250 250 168 179 169 166 156 166 156 166 166 166 177
                177 177 177 177 165 177 168 252 8 37 8 251 209 179 177 167 177 177 155 145 169 250
                250 250 250 250 250
              )
              (250 250 250 250 250 250 250 250 250 179 168 169 169 156 156 166 177 177 177 177 177
                177 177 167 167 155 251 251 252 252 35 35 37 251 250 179 159 177 177 177 163 167 250
                250 250 250 250 250
              )
              (250 250 250 250 250 250 250 250 250 168 179 179 179 169 177 177 177 159 167 8 251
                251 251 251 219 251 251 8 253 253 33 45 35 8 251 188 179 169 159 179 163 167 168 250
                250 250 250 250
              )
              (250 250 250 250 250 250 250 250 250 168 179 179 169 177 177 177 187 8 8 251 251 251
                251 49 39 49 251 47 253 33 33 23 35 252 252 219 168 169 169 159 145 159 168 250 250
                250 250 19
              )
              (250 250 250 250 250 250 250 250 250 168 179 179 177 177 209 251 252 252 251 251 251
                251 59 49 251 251 37 37 35 252 45 35 35 35 252 253 179 169 179 177 145 168 250 250
                250 250 38
              )
              (250 250 250 250 250 250 250 250 168 168 169 177 199 209 251 8 8 27 37 37 59 49 49
                251 251 251 37 37 37 47 35 47 37 35 252 253 251 179 169 155 149 168 250 250 250 38
                38 47
              )
              (250 250 250 250 250 250 250 250 168 168 169 177 209 251 251 252 59 59 37 59 49 251
                251 251 251 251 251 251 27 25 35 252 8 35 252 253 253 219 177 8 250 250 250 28 19 39
                55
              )
              (250 250 250 250 28 28 250 250 168 179 159 199 251 251 35 37 49 37 27 59 37 37 27 27
                37 8 8 8 252 8 252 253 33 252 35 23 253 252 251 209 250 250 250 19 29 37
              )
              (250 250 250 250 38 28 250 250 168 169 159 209 251 37 35 39 37 37 49 37 35 35 35 35 8
                8 252 252 252 33 253 253 253 253 33 252 253 253 251 250 250 250 250 38 38 45
              )
              (250 250 250 250 38 250 250 250 179 159 177 209 27 37 27 37 37 27 35 25 35 35 23 35
                23 23 23 23 23 33 253 253 9 9 253 33 23 253 8 19 250 250 250 38 39
              )
              (250 250 250 250 250 250 250 250 179 149 199 250 27 35 27 35 25 25 35 35 23 35 35 35
                23 23 23 23 33 33 33 253 253 9 253 33 33 253 253 19 250 250 250 28 45
              )
              (250 250 250 250 250 250 250 250 179 177 209 250 37 37 37 35 25 35 35 35 23 35 35 35
                23 23 23 23 33 33 33 253 253 253 253 33 33 33 253 27 18 19 28 39
              )
              (19 250 250 250 250 250 250 250 169 177 199 229 35 37 25 35 25 35 35 35 35 23 35 35
                35 35 23 45 23 23 33 33 253 33 33 33 33 253 253 254 27 28 37 254
              )
              (19 19 250 250 250 250 250 250 159 177 209 239 35 37 35 35 35 23 23 35 35 35 45 35 35
                35 23 35 23 23 33 33 253 33 33 33 33 253 33 33 253 45 254
              )
              (29 29 250 250 250 250 250 250 149 251 229 251 35 37 23 25 35 23 35 35 35 35 35 35 35
                35 35 23 35 35 23 33 253 33 33 23 33 33 33 43 33
              )
              (29 19 250 250 250 250 250 250 209 251 239 37 25 35 35 25 23 23 35 35 35 35 35 35 35
                35 35 35 23 23 23 33 33 33 33 23 33 33 33 33 33 33
              )
              (38 19 29 250 250 250 250 250 251 251 249 25 25 35 35 35 23 23 35 35 35 25 35 35 35
                23 23 23 23 23 33 21 33 33 23 23 33 33 253 33 33 33 43
              )
              (28 29 19 29 29 250 250 250 209 251 39 37 35 35 35 35 23 23 35 35 35 35 35 35 35 35
                35 35 23 45 23 23 23 33 35 35 33 33 253 33 33 9 33
              )
              (38 38 19 19 19 19 250 250 250 219 49 37 35 35 35 45 23 23 35 35 35 25 27 27 25 35 35
                35 45 37 17 39 27 27 25 35 33 33 253 33 23 253 33 43
              )
              (43 28 19 19 19 19 250 250 250 49 49 37 25 35 35 23 23 23 35 25 27 29 17 25 27 35 35
                25 37 252 35 35 49 27 35 23 33 33 33 33 23 253 253 43 43
              )
              (254 45 28 19 19 19 250 250 250 19 59 35 25 35 45 23 45 45 35 27 19 17 37 37 33 45 25
                45 37 37 37 27 23 33 23 23 33 33 33 33 33 33 253 9 35 33
              )
              (-2 254 45 38 28 38 19 19 19 28 39 35 35 35 45 45 23 45 35 25 27 17 37 37 37 27 25 25
                25 35 35 33 33 33 33 23 23 23 33 33 33 33 253 9 33 33
              )
              (-2 -2 254 9 47 48 38 38 28 28 48 35 35 45 45 23 45 45 35 35 35 25 25 25 35 45 35 35
                23 23 23 23 33 33 33 23 45 23 23 23 23 33 9 253 43 21
              )
              (-2 -2 -2 254 254 41 43 35 37 27 27 35 35 35 45 23 23 35 35 35 35 35 35 35 35 23 35
                35 35 23 35 33 33 23 35 35 35 23 33 23 33 253 9 253 21 21 33
              )
              (-2 -2 -2 -2 -2 -2 -2 254 254 254 33 35 35 35 35 45 45 35 35 35 25 25 35 35 35 35 35
                25 35 35 23 23 23 35 35 35 23 23 33 23 33 9 9 253 21 33 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 35 35 35 45 35 23 35 35 35 45 35 35 35 35 35 35 25 35
                35 23 35 35 35 35 35 35 23 33 33 33 33 9 9 9 21 33 33 43
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 23 35 45 35 23 35 23 23 35 35 23 35 35 25 25 35 23 23
                23 253 253 35 23 35 35 23 33 33 33 33 31 9 9 9 31 21 33 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 23 35 35 35 23 23 23 33 23 35 35 35 25 25 35 23 33 33
                33 253 254 9 33 25 23 33 33 33 33 21 9 254 9 9 21 33 33 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 23 35 45 35 23 23 23 33 33 23 25 35 35 23 35 23 23 23
                33 31 33 33 35 35 33 33 33 33 33 21 31 254 9 9 253 25 33 33 43
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 45 35 35 23 23 23 23 33 33 33 23 35 35 35 25 35 23 23
                33 31 21 23 35 33 33 33 33 33 33 21 253 9 254 9 9 33 9 33 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 43 45 23 35 23 23 33 33 33 33 33 33 23 35 25 23 13 23 23
                23 21 21 33 33 33 33 33 23 23 23 23 33 43 253 9 9 253 253 33 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 33 23 23 35 23 23 23 23 23 23 33 33 33 33 23 23 23 23 23
                33 21 33 23 33 35 23 33 33 33 23 33 253 253 33 9 9 253 33 23 45
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 33 45 23 23 23 33 33 23 23 23 23 35 35 23 23 23 23 35 23
                33 21 33 35 23 33 33 33 33 33 33 253 253 9 9 252 254 9 9 33 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 33 35 23 45 23 23 35 45 35 35 23 35 35 35 35 27 35 23 23
                23 33 33 45 33 252 33 33 33 33 33 253 253 33 253 252 254 253
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 33 35 23 23 23 45 45 23 23 23 23 23 23 23 23 35 27 35 23
                23 33 35 45 35 252 252 33 33 33 252 33 35 45 33 253 35 35 35 253
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 33 23 23 23 23 23 23 45 23 33 33 33 33 23 23 35 37 37 23
                23 33 25 37 37 37 37 37 49 37 37 39 37 252 33 253 35 33 27
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 45 45 33 23 45 23 35 35 33 23 45 33 23 45 35 35 37 17 35
                33 23 37 35 27 8 252 251 59 49 37 47 35 33 33 253 35 37 253 254 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 45 45 33 35 45 23 33 37 37 27 27 49 27 37 27 35 33 35 35
                33 23 253 252 252 253 252 251 47 8 8 252 253 253 253 253 28 27 9 9 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 43 45 37 35 35 33 45 27 37 49 49 49 37 37 252 254 254
                252 33 33 252 37 8 252 8 8 8 252 252 8 8 47 37 35 253 9 9 9 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 45 27 25 37 45 33 45 35 35 8 35 35 252 252 9 253 39
                27 35 35 27 27 252 8 49 39 49 49 27 37 252 254 254 254 9 9 9 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 31 33 33 45 27 45 35 35 33 33 252 252 35 47 37 27 39 27 8
                45 23 33 252 252 8 8 35 47 35 35 35 33 254 254 254 9 9 253 254 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 43 33 45 39 37 37 37 37 37 37 49 27 49 27 35 252 253
                253 253 33 253 33 253 253 253 253 253 33 33 33 9 254 254 9 254 9 9 254 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 43 33 35 25 37 37 27 17 49 27 37 35 33 33 23 33 33
                33 33 33 33 253 253 253 253 253 33 9 253 9 9 254 254 254 254 9 254 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 43 33 23 23 23 23 45 35 35 35 23 33 33 33 33 33 33
                33 33 23 33 33 33 33 43 21 21 43 253 9 9 254 254 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 43 43 33 23 23 23 33 33 33 33 33 33 33 33 33 33 33
                33 33 33 33 33 33 33 33 33 21 21 253 33 254 254 254 254 254
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 33 33 23 23 23 23 23 33 33 33 33 33 33 33 33 33
                33 33 33 33 33 33 33 33 33 33 43 253 253 9 254 254 254 254 253
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 43 33 23 23 23 23 23 23 23 23 23 23 33 33 33 33
                33 33 33 33 33 33 33 33 33 33 253 253 253 254 254 254 254 254 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 33 33 23 23 33 33 23 23 23 23 23 33 33 33 33
                33 33 33 33 33 33 33 33 33 33 253 9 253 9 254 254 254 253 33 43
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 33 45 33 23 23 33 23 23 33 33 33 33 33 33 33
                33 33 33 33 33 33 33 33 33 43 253 9 9 9 254 9 9 23 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 23 33 33 23 23 23 23 33 33 33 33 33 33 33
                33 33 33 33 33 33 33 33 33 21 31 31 9 9 9 254 33 45 43
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 43 23 33 23 23 23 23 33 33 23 23 33 33 33
                33 33 33 33 33 33 33 33 33 21 21 31 43 43 31 9 35 45
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 45 33 33 23 23 23 23 23 23 23 33 33 33
                33 33 33 33 33 33 33 33 33 33 21 33 21 21 31 23 35 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 31 33 33 33 33 23 23 23 23 23 23 23 23
                33 33 33 33 33 33 33 33 33 33 33 21 21 43 23 27 45
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 33 45 33 33 33 23 23 23 23 33 33 23
                33 33 33 33 33 33 33 33 33 43 33 21 43 45 27 27
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 33 45 33 33 33 23 33 23 23 23 23
                33 23 33 33 33 33 33 35 23 33 33 33 45 27 37 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 35 37 23 33 33 33 23 23 23 23
                23 23 23 23 23 35 35 35 35 35 45 37 27 37 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 33 37 25 35 35 35 45 35 35
                45 35 35 35 35 35 37 37 37 27 27 27 35 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 45 46 37 25 25 35 25 35
                35 35 35 35 35 25 27 27 27 37 35 37 33
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 33 45 37 37 35 37 37
                37 37 35 37 35 37 25 35 35 45 33 43
              )
              (-2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 45 45 35 25 37
                37 37 35 35 45 35 33 43 43 43
              )
              )
    (foreach y x (apply 'fill_image (list horiz verti 1 1 y)) (setq horiz (1+ horiz)))
    (setq verti (1- verti))
    (setq horiz h)
  )
  (end_image)
)
;;;================================================================================================

Un saludo

Aqui subo la rutina DTarear.lsp
Marca_ldg.lsp y Foto_ldg.lsp necesarias, ya estan mas arriba.

Código:

; Crea tabla con las areas y perimetros de los recintos cerrados indicados.
 ; Calcula area/perimetro y lados, y los escribe en una tabla, en un fichero.XLSX ò fichero.CSV y en su interior.
 ; Luis Dominguez Gomez :copyright: 2016
;;;================================================================================================
(defun dialog_areas ()
  (setq file (vl-filename-mktemp nil nil ".dcl"))
  (setq indi (open file "W"))
  (foreach str ;
               (list
                 "temp:dialog{key="rotulo";" ;
                 "  :row{" ;
                 "    :boxed_column{fixed_width=true;label=" Datos de Texto ";" ;
                 "      spacer;" ;
                 "      :edit_box{label="Altura";key="alt";fixed_width_font=true;" ;
                 "        allow_accept=true;edit_width=4;edit_limit=5;" ;
                 "      }" ;
                 "      :edit_box{label="Decimales";fixed_width_font=true;allow_accept=true;" ;
                 "        edit_width=0.5;edit_limit=1;key="dec";" ;
                 "      }" ;
                 "      :edit_box{label="Prefijo";fixed_width_font=true;allow_accept=true;" ;
                 "        edit_width=7;edit_limit=8;key="pre";" ;
                 "      }" ;
                 "      spacer;" ;
                 "    }" ;
                 "    :column{" ;
                 "      :image{key="marca";height=6;aspect_ratio=0.5;color=dialog_background;}" ;
                 "      :image{key="foto";height=4.7;aspect_ratio=0.8;color=dialog_background;}"
                 "    }" ;
                 "    :column{" ;
                 "      :boxed_column{label=" Opciones Reporte ";" ;
                 "        :toggle{label="Tabla de Areas";key="tab";}" ;
                 "        :toggle{label="Area en Poly";key="sup";}" ;
                 "        :toggle{label="Perimetro en Poly";key="per";}" ;
                 "      }" ;
                 "      :boxed_row{label=" Fichero ";" ;
                 "        spacer;" ;
                 "        :radio_button{label="XLSX";key="xls";}" ;
                 "        :radio_button{label="CSV";key="csv";}" ;
                 "      }" ;
                 "    }" ;
                 "  }" ;
                 "  :boxed_row{label=" Tramos de Poly ";" ;
                 "    spacer;" ;
                 "    :toggle{label="Longitud";key="lon";}" ;
                 "    :toggle{label="Rumbo";key="rum";}" ;
                 "  }" ;
                 "  ok_cancel_help;" ;
                 "  :boxed_column{label=" Luis Dominguez Gómez  :copyright:2007 ";" ;
                 "    :text{key="fecha";alignment=centered;}" ;
                 "  }" ;
                 "}" ;
                 "ayuda_areas:dialog{label=" Ayuda   DTAREAR  :copyright:2016";" ;
                 "  :list_box{key="ayuda";height=20;width=100;fixed_width_font=true;}" ;
                 "  :row{" ;
                 "    :boxed_column{label="Autor y propietario";fixed_width=true;" ;
                 "      :text{label=" Luis Dominguez Gómez ";alignment=centered;}" ;
                 "    }" ;
                 "    :image{height=3.5;key="marca";color=dialog_background;}" ;
                 "    ok_only;" ;
                 "  }" ;
                 "}"
                )
    (write-line str indi)
  )
  (close indi)
)
;;;================================================================================================
(defun cuadro_areas ()
  (set_tile "rotulo" (strcat " D T A R E A R   :copyright:" (substr (rtos (getvar 'cdate) 2 4) 1 4)))
  (marca_ldg)
  (foto_ldg 64 0) ;V-H
  (if *scl*
    (set_tile "alt" (rtos *scl* 2 2))
    (set_tile "alt" (rtos (getvar 'textsize) 2 2))
  )
  (if *dec*
    (set_tile "dec" (itoa *dec*))
    (set_tile "dec" "3")
  )
  (if *pre*
    (set_tile "pre" *pre*)
    (set_tile "pre" "")
  )
  (mapcar 'action_tile
          '("accept" "cancel" "help")
          '("(ok_areas)(done_dialog)" "(exit)" "(ayuda_areas)")
  )
  (set_tile "fecha" (menucmd "M=$(edtime, $(getvar,date),DDDD"" DD MONTH YYYY - HH:MM)h"))
)
;;;================================================================================================
(defun entorno_areas nil
  (if (not (tblobjname "STYLE" "TABLA"))
    (entmake (list '(0 . "STYLE") '(100 . "AcDbSymbolTableRecord")
                   '(100 . "AcDbTextStyleTableRecord") '(2 . "TABLA") '(70 . 0) '(40 . 0.0)
                   '(41 . 1.0) '(50 . 0.0) '(71 . 0) '(3 . "Consolas") '(4 . "")
                  )
    )
  )
  (setvar 'textstyle "TABLA")
  (if (not (tblobjname "LAYER" "TABLA_AREAS"))
    (entmake (list '(0 . "LAYER") '(100 . "AcDbSymbolTableRecord") '(100 . "AcDbLayerTableRecord")
                   '(2 . "TABLA_AREAS") '(70 . 0) '(62 . 8) '(6 . "CONTINUOUS")
                  )
    )
  )
  (setvar 'clayer "TABLA_AREAS")
)
;;;================================================================================================
(defun crea_tabla ()
  (setvar 'luprec *dec*)
  (setq acm (vla-getinterfaceobject
              (vlax-get-acad-object)
              (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2))
            )
  )
  (setq punto (getpoint "\nPunto Inserción Tabla: "))
  (setq tabla (vla-addtable ;crea tabla
                (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object)))
                (vlax-3d-point punto)
                2 ;rows
                3 ;columnas
                *scl* ;altura texto
                *scl* ;altura texto
              )
  )
  (vla-put-titlesuppressed tabla :vlax-false) ;activa titulo
  (vla-put-headersuppressed tabla :vlax-false) ;activa cabecera
  (vla-put-regeneratetablesuppressed tabla :vlax-true) ;regenerar/suprimirla
  (vla-put-vertcellmargin tabla (* *scl* 0.25)) ;margen vertical
  (vla-put-horzcellmargin tabla (* *scl* 0.25)) ;margen horizontal
  (vla-setrowheight tabla 0 *scl*) ;altura row 1
  (vla-setrowheight tabla 1 *scl*) ;altura row 2
  (vla-setcolumnwidth tabla 0 (* *scl* 8)) ; ancho columna 1
  (vla-setcolumnwidth tabla 1 (* *scl* 15)) ; ancho columna 2
  (vla-setcolumnwidth tabla 2 (* *scl* 12)) ; ancho columna 3
  (vla-settextstyle tabla actitlerow "TABLA") ;Estilo texto titulo
  (vla-settextstyle tabla acheaderrow "TABLA") ;Estilo texto cabecera
  (vla-settextstyle tabla acdatarow "TABLA") ;Estilo texto celdas
  (vla-settextheight tabla actitlerow (* *scl* 1.5)) ;altura texto titulo
  (vla-settextheight tabla acheaderrow *scl*) ;altura texto cabecera
  (vla-settextheight tabla acdatarow *scl*) ;altura texto celdas
  (vla-setalignment tabla actitlerow acmiddlecenter) ;alineacion titulo
  (vla-setalignment tabla acheaderrow acmiddlecenter) ;alineacion cabecera
  (vla-setalignment tabla acdatarow acmiddleright) ;alinacion datos
  (vla-settext tabla 1 0 "Recintos")
  (vla-settext tabla 1 1 "Areas")
  (vla-settext tabla 1 2 "Perimetros")
  (vla-put-colorindex acm 7) ;blanco
  (vla-setcellcontentcolor tabla 0 0 acm)
  (vla-put-colorindex acm 3) ;verde
  (vla-setcellcontentcolor tabla 1 0 acm)
  (vla-put-colorindex acm 1) ;rojo
  (vla-setcellcontentcolor tabla 1 1 acm)
  (vla-put-colorindex acm 2) ;amarillo
  (vla-setcellcontentcolor tabla 1 2 acm)
  (vla-put-regeneratetablesuppressed tabla :vlax-false) ;regenera tabla
)
;;;================================================================================================
(defun ok_areas ()
  (setq *scl* (atof (get_tile "alt")))
  (setq *dec* (atoi (get_tile "dec")))
  (setq *pre* (get_tile "pre"))
  (setq tab (get_tile "tab"))
  (setq xls (get_tile "xls"))
  (setq csv (get_tile "csv"))
  (setq per (get_tile "per"))
  (setq sup (get_tile "sup"))
  (setq lon (get_tile "lon"))
  (setq rum (get_tile "rum"))
  (setq na 1) ;numero actual
)
;;;================================================================================================
(defun puntos ()
  (setq recinto (strcat *pre* (itoa na)))
  (if (and (/= pto nil)
           (or (= tab "1") (= xls "1") (= csv "1") (= per "1") (= sup "1") (= lon "1") (= rum "1"))
      )
    (progn (vl-cmdf "_bpoly" pto "")
           (setq poly (vlax-ename->vla-object (entlast)))
           (setq area (vla-get-area poly))
           (setq peri (vla-get-length poly))
           (if (or (= lon "1") (= rum "1"))
             (tramos_rumbos poly)
           )
           (vla-delete poly)
    )
  )
  (entmake (list '(0 . "MTEXT")
                 '(100 . "AcDbEntity")
                 '(8 . "TABLA_AREAS")
                 '(100 . "AcDbMText")
                 '(62 . 1)
                 (cons 10 pto)
                 (cons 40 *scl*)
                 (cond ((and (= per "0") (= sup "0")) (cons 1 (strcat "\\pxqc;" recinto)))
                       ((and (= per "0") (= sup "1"))
                        (cons 1 (strcat "\\pxqc;" recinto "\\PArea=" (rtos area 2 *dec*) "m²"))
                       )
                       ((and (= per "1") (= sup "0"))
                        (cons 1 (strcat "\\pxqc;" recinto "\\PPerim=" (rtos peri 2 *dec*) "m"))
                       )
                       ((and (= per "1") (= sup "1"))
                        (cons 1
                              (strcat "\\pxqc;"
                                      recinto
                                      "\\PArea="
                                      (rtos area 2 *dec*)
                                      "m²\\PPerim="
                                      (rtos peri 2 *dec*)
                                      "m"
                              )
                        )
                       )
                 )
                 '(7 . "TABLA")
                 (cons 11 pto)
                 '(50 . 0.0)
           )
  )
  (setq acum_area (+ acum_area area))
  (setq acum_peri (+ acum_peri peri))
  (setq na (1+ na))
)
;;;================================================================================================
(defun areas ()
  (setq ni (itoa na)) ;numero inicial
  (setq acum_area 0.0)
  (setq acum_peri 0.0)
  (if (= xls "1")
    (file_ini_xls)
  )
  (if (= csv "1")
    (file_ini_csv)
  )
  (if (= tab "1")
    (crea_tabla)
  )
  (while (setq pto (getpoint (strcat "\nIndicar Punto Interior: <" (itoa na) ">")))
    (puntos)
    (if (= tab "1")
      (ins_row)
    )
    (if (= xls "1")
      (file_row_xls)
    )
    (if (= csv "1")
      (file_row_csv)
    )
  )
  (if (= tab "1")
    (progn (vla-settext
             tabla
             0
             0
             (strcat "Tabla Areas y Perimetros Recintos del " ni " al " (itoa (1- na)))
           )
           (end_row)
    )
  )
  (if (= xls "1")
    (file_end_xls)
  )
  (if (= csv "1")
    (file_end_csv)
  )
)
;;;================================================================================================
(defun file_ini_xls ()
  (abre_excel)
  (escribe "A2" (list "Recintos" "Areas" "Perimetros"))
  (setq fila 3)
)
;;;================================================================================================
(defun file_ini_csv ()
  (alert "El [archivo.CSV] se creará \nen el directorio actual ")
  (setq arch (getstring "\nNombre archivo: [Sin extension]"))
  (setq arch (strcat (getvar 'dwgprefix) arch ".csv"))
  (setq indi (open arch "w"))
  (write-line "TABLA de AREAS y PERIMETROS\nRecintos;Areas;Perimetros" indi)
  (close indi)
)
;;;================================================================================================
(defun file_row_xls ()
  (escribe (strcat "A" (itoa fila))
           (list recinto (strcat (rtos area 2 *dec*) " m²") (strcat (rtos peri 2 *dec*) " m"))
  )
  (setq fila (1+ fila))
)
;;;================================================================================================
(defun file_row_csv ()
  (setq indi (open arch "a"))
  (write-line (strcat recinto ";" (rtos area 2 *dec*) " m²;" (rtos peri 2 *dec*) " m") indi)
  (close indi)
)
;;;================================================================================================
(defun file_end_xls ()
  (escribe "A1" (strcat "Tabla de Recintos del " ni " al " (itoa (1- na))))
  (escribe
    (strcat "A" (itoa fila))
    (list "Totales" (strcat (rtos acum_area 2 *dec*) " m²") (strcat (rtos acum_peri 2 *dec*) " m"))
  )
  (cierra_excel)
)
;;;================================================================================================
(defun file_end_csv ()
  (setq indi (open arch "a"))
  (write-line
    (strcat "Totales;" (rtos acum_area 2 *dec*) " m²;" (rtos acum_peri 2 *dec*) " m")
    indi
  )
  (close indi)
)
;;;================================================================================================
(defun ayuda_areas ()
  (new_dialog "ayuda_areas" indi)
  (marca_ldg 45 0) ;V-H
  (action_tile "accept" "(done_dialog)")
  (start_list "ayuda")
  (mapcar
    'add_list
    (list
      "· La Altura del texto, se puede cambiar y es obligatoria." ;
      "  (Al inicio, se impone la altura por defecto actual.)" ;
      "  (recuerda cada vez la ultima altura usada.)" ;
      "" ;
      "· La precisión decimal, se pueden cambiar." ;
      "  (Al inicio, se impone 3 decimales.)" ;
      "  (recuerda cada vez la ultima precisión usada.)" ;
      "" ;
      "· El prefijo no es obligatorio." ;
      "  (Texto que va delante del numero de orden.)" ;
      "  (Si existe, siempre se puede cambiar.)" ;
      "" ;
      "· Tabla de Areas, no es obligatoria." ;
      "  (Incluye Nº de recinto, Area de recinto y Perimetro de recinto)" ;
      "  (Tabla de Areas en m² y Perimetros en Mts. de todos los recintos cerrados elegidos.)" ;
      "" ;
      "· Area en Poly, no es obligatorio." ;
      "  (Es el valor del Area en m² escrito debajo del Nº del recinto.)" ;
      "" ;
      "· Perimetro en Poly, no es obligatorio." ;
      "  (Es el valor del Perimetro en Mts. escrito debajo del Area del recinto.)" ;
      "" ;
      "· Fichero, no es obligatorio." ;
      "  (Incluye Nº de recinto, Area, Perimetro y totales)" ;
      "  (Fichero con Areas m², Perimetros Mts, y totales, de todos los recintos cerrados elegidos.)"
      "  (Se puede elegir reporte en Fichero.XLSX ó Fichero.CSV.)" ;
      "" ;
      "· Longitud, no es obligatorio." ;
      "  (Longitud de cada tramo recto o curvo del recinto cerrado elegido.)" ;
      "  (Se escribe orientado y en el centro geometrico de cada tramo.)" ;
      "" ;
      "· Rumbo, no es obligatorio." ;
      "  (Angulo en g. m. s. direccionado a un cuadrante (NorteEste, NorteOeste, SurEste o SurOeste.)"
      "  (Se escribe orientado y en el centro geometrico de cada tramo. ejem. S 82°20'17" E)" ;
      "" ;
     )
  )
  (end_list)
  (action_tile "accept" "(done_dialog 1)")
  (start_dialog)
)
;;;================================================================================================
(defun ins_row ()
  (vla-insertrows tabla conta 1 1) ;insertamos fila
  (vla-settextstyle tabla acdatarow "TABLA") ;estilo texto
  (vla-settextheight tabla acdatarow *scl*) ;altura texto celdas
  (vla-setalignment tabla acdatarow acmiddleright) ;alineacion derecha
  (vla-setrowheight tabla conta 1) ;altura fila
  (vla-settext tabla conta 0 recinto) ;punto
  (vla-put-colorindex acm 3) ;verde
  (vla-setcellcontentcolor tabla conta 0 acm)
  (vla-settext tabla conta 1 (strcat (rtos area 2 *dec*) " m²")) ;area
  (vla-put-colorindex acm 1) ;rojo
  (vla-setcellcontentcolor tabla conta 1 acm)
  (vla-settext tabla conta 2 (strcat (rtos peri 2 *dec*) " m")) ;perimetro
  (vla-put-colorindex acm 2) ;amarillo
  (vla-setcellcontentcolor tabla conta 2 acm)
  (setq conta (1+ conta))
)
;;;================================================================================================
(defun end_row ()
  (vla-insertrows tabla conta 1 1) ;insertamos fila
  (vla-settextstyle tabla acdatarow "TABLA") ;estilo texto
  (vla-settextheight tabla acdatarow *scl*) ;altura texto celdas
  (vla-setalignment tabla acdatarow acmiddleright) ;alineacion derecha
  (vla-setrowheight tabla conta 1) ;altura fila
  (vla-settext tabla conta 0 "Totales") ;totales
  (vla-put-colorindex acm 3) ;verde
  (vla-setcellcontentcolor tabla conta 0 acm)
  (vla-settext tabla conta 1 (strcat (rtos acum_area 2 *dec*) " m²")) ;total areas
  (vla-put-colorindex acm 1) ;rojo
  (vla-setcellcontentcolor tabla conta 1 acm)
  (vla-settext tabla conta 2 (strcat (rtos acum_peri 2 *dec*) " m")) ;total perimetros
  (vla-put-colorindex acm 2) ;amarillo
  (vla-setcellcontentcolor tabla conta 2 acm)
)
;;;================================================================================================
(defun tramos_rumbos (poly)
  (setq explst (vlax-invoke poly 'explode))
  (foreach x explst
    (setq ins (vlax-curve-getpointatdist
                x
                (/ (vlax-curve-getdistatparam x (vlax-curve-getendparam x)) 2.0)
              )
    )
    (setq ini (vlax-curve-getstartpoint x))
    (setq end (vlax-curve-getendpoint x))
    (setq ang (rem (angle ini end) pi))
    (setq len (rtos (vlax-curve-getdistatpoint x end) 2 *dec*))
    (setq rumbo (vl-string-subst (chr 176) "d" (angtos (angle ini end) 4 3)))
    (if (> ang (/ pi 2.0))
      (setq ang (+ pi ang))
    )
    (setq ins (polar ins (+ ang (/ pi 2)) *scl*))
    (entmake (list (cons 0 "TEXT")
                   (cond ((and (= lon "1") (= rum "0")) (cons 1 len))
                         ((and (= lon "0") (= rum "1")) (cons 1 rumbo))
                         ((and (= lon "1") (= rum "1")) (cons 1 (strcat "(" len ")(" rumbo ")")))
                   )
                   (cons 7 (getvar 'textstyle))
                   '(62 . 1)
                   (cons 10 ins)
                   (cons 11 ins)
                   (cons 40 *scl*)
                   (cons 50 ang)
                   (cons 72 1)
                   (cons 73 2)
             )
    )
    (vla-delete x)
  )
)
;;;================================================================================================
(defun abre_excel ()
  (setq excel (vlax-get-or-create-object "excel.application"))
  (setq libros (vlax-get-property excel "workbooks"))
  (setq libro (vlax-invoke-method libros "add"))
  (vla-put-visible excel :vlax-true)
)
;;;================================================================================================
(defun cierra_excel ()
  (vlax-release-object libro)
  (vlax-release-object libros)
  (vlax-release-object excel)
  (gc)
)
;;;================================================================================================
(defun escribe (celda_inic datos)
  (if (= (type datos) 'str)
    (setq datos (list datos))
  )
  (setq rango (vlax-get-property excel "Cells"))
  (if (celda-p celda_inic)
    (setq col (car (col_row celda_inic))
          row (cadr (col_row celda_inic))
    )
  )
  (if (and col row)
    (foreach item datos
      (vlax-put-property rango "Item" row col (vl-princ-to-string item))
      (setq col (1+ col))
    )
  )
)
;;;================================================================================================
(defun col_row (celda)
  (setq colum "")
  (while (< 64 (ascii (setq carac (strcase (substr celda 1 1)))) 91)
    (setq colum (strcat colum carac)
          celda (substr celda 2)
    )
  )
  (if (and (/= colum "") (numberp (setq row (read celda))))
    (list (columa_numero colum) row)
    '(1 1)
  )
)
;;;================================================================================================
(defun columa_numero (cadena)
  (if (= 0 (setq canti (strlen cadena)))
    0
    (+ (* (- (ascii (strcase (substr cadena 1 1))) 64) (expt 26 (1- canti)))
       (columa_numero (substr cadena 2))
    )
  )
)
;;;================================================================================================
(defun celda-p (celda)
  (and (= (type celda) 'str) (or (= (strcase celda) "A1") (not (equal (col_row celda) '(1 1)))))
)
;;;================================================================================================
(defun c:dtarear (/ acm acum_area acum_peri ang area canti celda col colum conta csv datos end excel
                  explst fila file indi ini ins len libro libros lon na ni per peri poly pto punto
                  rango recinto row rum rumbo sup tab tabla xls
                 )
  (vl-load-com)
  (setvar 'cmdecho 0)
  (vla-startundomark (vla-get-activedocument (vlax-get-acad-object)))
  (vl-cmdf "_ucs" "_w")
  (setq conta 2)
  (dialog_areas)
  (setq indi (load_dialog file))
  (new_dialog "temp" indi)
  (if (not marca_ldg)
    (load "marca_ldg")
  )
  (if (not foto_ldg)
    (load "foto_ldg")
  )
  (cuadro_areas)
  (vl-file-delete file)
  (start_dialog)
  (unload_dialog indi)
  (entorno_areas)
  (areas)
  (setvar 'orthomode 0)
  (if (= tab "1")
    (vl-cmdf "_move" (vlax-vla-object->ename tabla) "" punto "\")
  )
  (vl-cmdf "_ucs" "_pr")
  (vla-endundomark (vla-get-activedocument (vlax-get-acad-object)))
  (prin1)
)
;;;================================================================================================


Saludos

Hola a tod@s.
Bueno Dominguez, resultó un gusto leerte aquí y en el viejo Hispacad (snif, snif)
Espero la sigas pasando bien en esta tu nueva etapa y muchas gracias por la voluntad de compartir tu esfuerzo.
Saludos cordiales

Muchísimas gracias, Domínguez!!!!!!! Estudiaré para aprender con tus rutinas!!!!!Gracias!!!!

Hola Domínguez (bueno, Don Luis...)

Que disfrutes de la merecida jubilación (a mi todavía me quedan unos pocos años...) y, sobre todo, que esos problemas de salud familiares que mencionas se pasen pronto y bien.

Un fuerte abrazo

Muchas gracias a todos por vuestro interes.

Con el lisp :DTcuadro_Coord.lsp
Comando: ; error: cdrs adicionales en par separado por un punto en entrada
con rutina lisp :DTarear.lsp
Comando: ; error: cadena formada incorrectamente en entrada

Luis Alberto Benitez escribió:Con el lisp :DTcuadro_Coord.lsp
Comando: ; error: cdrs adicionales en par separado por un punto en entrada
con rutina lisp :DTarear.lsp
Comando: ; error: cadena formada incorrectamente en entrada

Bueno, a mi no me salen esos errores, pero encuanto pueda lo estudiare.

Lo siento tocayo, pero he probado las dos rutinas DTcuadro_coor.lsp y DTarear y me funcionan de lujo, asi que no te puedo ayudar, yo tengo Autocad18, no se tu.

Ok Maestro yo uso el 12 pero estaré investigando los errores que arroja.
Gracias

Gracias por todo maestro Dominguez, aun utilizo su generados de cuadros de construcción!! saludos y nuevamente gracias.