Longitud de Lineas x Tipo

Ver el tema anterior Ver el tema siguiente Ir abajo

Longitud de Lineas x Tipo

Mensaje por Zicaryd el Dom Oct 08, 2017 1:38 am

Buen dia estimados, aca de nuevo tratando de solucionar un tema que se me presenta.

Tengo Líneas que están en diferentes capas, quisiera poder hacer seleccion una parte de ellas y que esto me genere a la vez un cuadro donde me indiquen las sumas de las longitudes de líneas o polilíneas selecionadas por capas.

https://drive.google.com/open?id=0B131sP2Zq1-QUWJGMWRGRG9XWUU

Ojala me puedan dar alguna idea de como lograrlo.

Saludos.

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Dom Oct 08, 2017 2:21 am

Tengo esta rutina que te suma las polilineas o lineas por selecciona y te muestra el total.
Código:

;;Suma lines y polilineas y te lo muestra en el Autocad                         
;;----------------------------------------------------------------------
(defun suma ()
  (initget "Polilinea Linea Ambas")
  (setq   tipo
    (getkword
     "\nIndique el tipo de objeto [Polilínea/Línea/Ambas] <Polilínea>: "
    )
  )
  (if (= tipo nil)
    (setq tipo "Polilinea")
  )
  (cond   ((= tipo "Polilinea") (suma-pol))
   ((= tipo "Linea") (suma-lin))
   ((= tipo "Ambas") (suma-amb))
  )
)

(defun suma-pol   ()
  (initget "Capa Seleccion")
  (setq opt (getkword "\nSumar por [Capa/Selección] <Selección>: "))
  (if (= opt nil)
    (setq opt "Seleccion")
  )
  (if (= opt "Seleccion")
    (progn
      (setq polilineas (ssget '((0 . "LWPOLYLINE"))))
      (if (/= polilineas nil)
   (progn
     (setq   n-pol (sslength polilineas)
      n    0
     )
     (repeat n-pol
       (setq nombre (ssname polilineas n))
       (progn
         (command "_.area" "_O" nombre)
         (setq lon (getvar "perimeter"))
         (setq longitud (cons lon longitud))
       )
       (setq n (1+ n))
     )
     (setq lon-total (apply '+ longitud))
     (alert (strcat "Longitud total de la(s) Polilínea(s) es : "
          (rtos lon-total)  " ud."
       )
     )
   ) ;_progn
     (alert "No se han encontrado Polilínea(s)")
      ) ;_if
    ) ;_progn
    (progn
      (setq sel-capa
       (cdr
         (assoc 8
            (entget (car (entsel "\nSeleccione entidad: ")))
         )
       )
      )
      (setq polilineas
       (ssget "_x"
          (list '(0 . "LWPOLYLINE") (cons 8 sel-capa))
       )
      )
      (if (/= polilineas nil)
   (progn
     (setq   n-pol (sslength polilineas)
      n    0
     )
     (repeat n-pol
       (setq nombre (ssname polilineas n))
       (if   (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
         (progn
      (command "_.area" "_O" nombre )
      (setq lon (getvar "perimeter"))
      (setq longitud (cons lon longitud))
         )
       )
       (setq n (1+ n))
     )
     (setq lon-total (apply '+ longitud))
     (alert
       (strcat "Longitud total de la(s) Polilínea(s) por capa "
          "\""
          sel-capa
          "\""
          " es : "
          (rtos lon-total)  " ud."
       )
     )
   ) ;_progn
   (alert "No se han encontrado Polilínea(s)")
      ) ;_if
    ) ;_progn
  ) ;_if
)

(defun suma-lin   ()
  (initget "Capa Seleccion")
  (setq opt (getkword "\nSumar por [Capa/Selección] <Selección>: "))
  (if (= opt nil)
    (setq opt "Seleccion")
  )
  (if (= opt "Seleccion")
    (progn
      (setq polilineas (ssget '((0 . "LINE"))))
      (if (/= polilineas nil)
   (progn
     (setq   n-pol (sslength polilineas)
      n    0
     )
     (repeat n-pol
       (setq nombre (ssname polilineas n))
           (progn
      (setq p1 (cdr (assoc 10 (entget nombre)))
            p2 (cdr (assoc 11 (entget nombre)))
      )
      (setq distancia-l (distance p1 p2))
      (setq lst-distancia (cons distancia-l lst-distancia))
         )
      
       (setq n (1+ n))
     )
     (setq lon-total (apply '+ lst-distancia))
     (alert (strcat "Longitud total de la(s) Línea(s) es : "
          (rtos lon-total) " ud."
       )
     )
   ) ;_progn
   (alert "No se han encontrado Línea(s)")
      ) ;_if
    ) ;_prong
    (progn
      (setq sel-capa
       (cdr
         (assoc 8
            (entget (car (entsel "\nSeleccione entidad: ")))
         )
       )
      )
      (setq polilineas
       (ssget "_x"
          (list '(0 . "LINE") (cons 8 sel-capa))
       )
      )
      (if (/= polilineas nil)
   (progn
     (setq   n-pol (sslength polilineas)
      n    0
     )
     (repeat n-pol
       (setq nombre (ssname polilineas n))
       (if   (= "LINE" (cdr (assoc 0 (entget nombre))))
         (progn
      (setq p1 (cdr (assoc 10 (entget nombre)))
            p2 (cdr (assoc 11 (entget nombre)))
      )
      (setq distancia-l (distance p1 p2))
      (setq lst-distancia (cons distancia-l lst-distancia))
         )
       )
       (setq n (1+ n))
     )
     (setq lon-total (apply '+ lst-distancia))
     (alert (strcat "Longitud total de la(s) Línea(s) por capa "
          "\""
          sel-capa
          "\""
          " es : "
          (rtos lon-total) " ud."
       )
     )
   ) ;_progn
   (alert "No se han encontrado Línea(s)")
      ) ;_if
    ) ;_progn
  ) ;_if
)

(defun suma-amb   ()
  (initget "Capa Seleccion")
  (setq opt (getkword "\nSumar por [Capa/Selección] <Selección>: "))
  (if (= opt nil)
    (setq opt "Seleccion")
  )
  (if (= opt "Seleccion")
    (progn
      (setq poli-lineas (ssget '((0 . "*LINE"))))
      (if (/= poli-lineas nil)
   (progn
     (setq   n-pol (sslength poli-lineas)
      n    0
     )
     (repeat n-pol
       (setq nombre (ssname poli-lineas n))
       (command "_.lengthen" nombre "")
       (setq lon (getvar "perimeter"))
       (setq longitud (cons lon longitud))
       (setq n (1+ n))
     )
     (setq lon-total (apply '+ longitud))
     (alert (strcat "Longitud total de la(s) *línea(s) es : "
          (rtos lon-total)  " ud."
       )
     )
   ) ;_progn
   (alert "No se han encontrado ninguna entidad(s) válida")
      ) ;_if
    ) ;_progn
    (progn
      (setq sel-capa
       (cdr
         (assoc 8
            (entget (car (entsel "\nSeleccione entidad: ")))
         )
       )
      )
      (setq poli-lineas
       (ssget "_x"
          (list '(0 . "*LINE") (cons 8 sel-capa))
       )
      )
      (if (/= poli-lineas nil)
   (progn
     (setq   n-pol (sslength poli-lineas)
      n    0
     )
     (repeat n-pol
       (setq nombre (ssname poli-lineas n))
       (progn
         (command "_.lengthen" nombre "")
         (setq lon (getvar "perimeter"))
         (setq longitud (cons lon longitud))
       )
       (setq n (1+ n))
     )
     (setq lon-total (apply '+ longitud))
     (alert
       (strcat "Longitud total de la(s) *línea(s) por capa "
          "\""
          sel-capa
          "\""
          " es : "
          (rtos lon-total)  " ud."
       )
     )
   ) ;_progn
   (alert "No se han encontrado ninguna entidad(s) válida")
      ) ;_if
    ) ;_progn
  ) ;_if
)

(defun c:slp   (/ tipo         polilineas  n-pol      n
        nombre      lon     longitud    lon-total
        p1         p2     distancia-l lst-distancia
        opt         sel-capa     poli-lineas
        )
  (setvar "cmdecho" 0)
  (suma)
  (setvar "cmdecho" 1)
  (prin1)
)
(prompt "Teclee la ORDEN: SLP ...")
(princ)

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Dom Oct 08, 2017 2:25 am

Compartos esta otra rutina que me genera una tabla pero de bloques y me realiza un conteo general.
Código:

 ; Contador de bloques en tabla, con modelo miniatura y nomenclatura.
 ;By Estilo&CONSTRUCCION
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun AddTextStyle (TxtStyleName Font doc / *Textstyles* NewStyle)
  (and   (setq *Textstyles* (vla-get-TextStyles doc))
   (not (collection-item-p *Textstyles* TxtStyleName))
   (setq NewStyle (vla-add *Textstyles* TxtStyleName))
   (vla-setFont NewStyle Font :vlax-false :vlax-false 0 0)
  )
  NewStyle
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun for-sset   (sset f / n)
  (if (= 'PICKSET (type sset))
      (repeat (progn (setq n -1) (sslength sset)) (f (ssname sset (setq n (1+ n)))))
  )
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun collection-item-p (collection Item)
  (cond ((vl-catch-all-error-p (vl-catch-all-apply 'vla-item (list Collection Item))) nil)
    (t (vla-item Collection Item))
  )
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun list->variantArray (ptsList / arraySpace sArray)
  (setq arraySpace (vlax-make-safearray vlax-vbdouble ;elemento tipo
                (cons 0 (- (length ptsList) 1)) ;_ array dimension
          )
  )
  (setq sArray (vlax-safearray-fill arraySpace ptsList))
  (vlax-make-variant sArray)
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun NameUnnamedUcs (*adoc* UcsName / *UCS* Origin XAxisPoint YAxisPoint)
  (if (= (getvar "WORLDUCS") 0) ;If UCS Difers from world then
      (progn (Setq *UCS*      (vla-get-UserCoordinateSystems *adoc*)
        Origin    (getvar "UCSORG")
        XAxisPoint (mapcar '(lambda (pt1 pt2) (+ pt1 pt2)) Origin (getvar "UCSXDIR"))
        YAxisPoint (mapcar '(lambda (pt1 pt2) (+ pt1 pt2)) Origin (getvar "UCSyDIR"))
       )
       (vla-add *Ucs*
            (list->variantArray Origin)
            (list->variantArray XAxisPoint)
            (list->variantArray YAxisPoint)
            UcsName
       )
      )
  )
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun GetBlocks (space /)
  (cond
      ((= (Type Space) 'STR) (vlax-for obj (vla-get-block (vla-item *layouts* space)) (bkobj obj)))
      ((= (Type Space) 'PICKSET)
      (for-sset Space (lambda (ename / obj) (setq obj (vlax-ename->vla-object ename)) (bkobj obj)))
      )
  )
  BkCountLst
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
(defun bkObj (obj / BkName)
  (cond ((/= (vla-get-ObjectName obj) "AcDbBlockReference"))
    ((and (setq BkName (vla-get-Name obj)) (assoc BkName BkCountLst))
     (setq   BkCountLst (subst (cons BkName (1+ (cdr (assoc BkName BkCountLst))))
              (assoc BkName BkCountLst)
              BkCountLst
           )
     )
    )
    (T (setq BkCountLst (cons (cons BkName 1) BkCountLst)))
  )
)
;;; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

(Defun c:BT (/ *acad*   *adoc* *Layouts* BkCountLst SpaceBkCt ptt *tabla* Table1 *BLOCKS*
            CTROW ROW *TABLESTYLE* CTC COL_CT LayName NwUcs ss
            )
  (vl-load-com)
  (setq *acad*     (vlax-get-acad-object)
    *adoc*     (vla-get-activedocument *acad*)
    *Layouts* (vla-get-Layouts *adoc*)
    *blocks*  (vla-get-Blocks *adoc*)
  )
  (vla-startundomark *adoc*)
  (or (setq NwUcs (collection-item-p (vla-get-UserCoordinateSystems *adoc*) "BTUcs")))
  (initget "Seleccionar ModelSpace PaperSpace Todos")
  (setq SpaceBkCt (GetKword "\n Count Blocks in [<Seleccinar>/ModelSpace/PaperSpace/Todos]"))
  (cond ((or (= SpaceBkCt "Selección") (= SpaceBkCt nil))
     (setq SpaceBkCt "Selección")
     (while (null ss) (setq ss (ssget '((0 . "INSERT")))))
     (princ "\n Getting Blocks in Selection...")
     (GetBlocks ss)
    )
    ((= SpaceBkCt "ModelSpace")
     (setq SpaceBkCt "Espacio  Modelo")
     (princ "\n Getting Blocks in ModelSpace...")
     (GetBlocks "Model")
    )
    ((= SpaceBkCt "PaperSpace")
     (initget "All Type Current")
     (setq GetPs (GetKword "\n Count Blocks in [<Current>/Type Name/All] layouts: "))
     (cond   ((or (= GetPs nil) (= GetPs "Current"))
       (princ "\n Getting Blocks in Current Layout...")
       (GetBlocks (getvar "ctab"))
       (setq SpaceBkCt "Capa  Actual")
      )
      ((= GetPs "All")
       (princ "\n Getting Blocks in all Layouts...")
       (setq Layouts (layoutlist))
       (foreach lay layouts (GetBlocks lay))
       (setq SpaceBkCt "all Layouts")
      )
      (t
       (while   (not (member LayName (mapcar 'strcase (layoutlist))))
          (setq LayName (strcase (getString "\n Type layout name: " T)))
       )
       (mapcar 'princ (list "\n Getting Blocks in Layout " LayName "..."))
       (GetBlocks LayName)
       (setq SpaceBkCt (strcat "Layout " LayName))
      )
     )
    )
    (t
     (princ "\n Getting Blocks in Paper and Model Space...")
     (setq Layouts (cons "Model" (layoutlist)))
     (foreach lay layouts (GetBlocks lay))
    )
  )
  (if BkCountLst
      (progn (setq BkCountLst (vl-sort BkCountLst (function (lambda (e1 e2) (< (car e1) (car e2))))))
       (princ "Done")
       (cond ((collection-item-p (vla-get-dictionaries *adoc*) "TablaBlocks"))
        (T
          (AddTextStyle "Anot_Arial" "ARIAL" *adoc*)
          (setq *tableStyle* (vla-item (vla-get-dictionaries *adoc*) "acad_tablestyle")
           *tabla*      (vla-addObject *tableStyle* "TablaBlocks" "AcDbTableStyle")
          )
          (vla-SetTextHeight *tabla* acTitleRow 5.0) ;altura texto rotulo principal
          (vla-SetTextHeight *tabla* acHeaderRow 3.5) ;altura texto rotulo bloques
          (vla-SetTextHeight *tabla* acDataRow 3.5) ;altura texto bloques
          (vla-SetTextStyle *tabla* acHeaderRow "Anot_Arial")
          (vla-SetTextStyle *tabla* acTitleRow "Anot_Arial")
          (vla-SetTextStyle *tabla* acDataRow "Anot_Arial")
          (vla-put-Vertcellmargin *tabla* 3.5)
          (vla-put-Horzcellmargin *tabla* 10.0)
        )
       )
       (or ptt
       (setq ptt ;(trans
          (getPoint "\nIndica punto de inserción de la tabla: ")
;;;          1
;;;          0
;;;        )
       )
       )
       (progn (princ "\n Creación de Tabla, espere por favor... ")
          (setq Ptt    (vlax-make-variant
                (vlax-safearray-fill (vlax-make-safearray vlax-vbDouble '(0 . 2)) ptt)
             )
           Table1 (vla-addTable (vla-get-ModelSpace *adoc*) ptt 2 3 0.2 2.0)
           ctc    0
          )
          (vla-put-StyleName Table1 "TablaBlocks")
          (vla-setText Table1
             0
             0
             (strcase (strcat "Bloques  en  "
                    (if (= SpaceBkCt "Todos")
                      "Dibujo"
                      SpaceBkCt
                    )
                 )
             )
          )
          (vla-setText Table1 1 0 "FIGURA")
          (vla-setText Table1 1 1 "NOMBRE  del  BLOQUE")
          (vla-setText Table1 1 2 "CANT")
          (vla-setcolumnwidth Table1 0 40.0) ;anchura columna bloque
          (vla-setcolumnwidth Table1 1 100.0) ;anchura columna nombre
          (vla-setcolumnwidth Table1 2 33.0) ;anchura columna cantidad
          (vla-setRowHeight Table1 0 5)
          (vla-setrowHeight Table1 1 3.5)
          (if   (setq NwUcs (NameUnnamedUcs *adoc* "BTUcs"))
            (progn (setq TransMatrix (vla-getUcsMatrix NwUcs))
               (vla-TransformBy Table1 TransMatrix)
            )
          )
       )
       (setq row 2)
       (foreach BksLst BkCountLst
      (vla-insertrows Table1 row 0.35 1)
      (setq Col_ct 0)
      (vla-SetCellType Table1 row Col_ct acBlockCell)
      (vla-SetBlockTableRecordId
        Table1
        row
        Col_ct
        (vla-get-ObjectID (vla-item *blocks* (car BksLst)))
        :vlax-true
      )
      (setq col_ct (1+ Col_Ct))
      (vla-SetText Table1
             (vlax-make-Variant row vlax-vbLong)
             Col_ct
             (vlax-Make-Variant (strcase (car BksLst)) Vlax-VbString)
      )
      (setq col_ct (1+ Col_Ct))
      (vla-SetText Table1
             (vlax-make-Variant row vlax-vbLong)
             Col_ct
             (vlax-Make-Variant (cdr BksLst) Vlax-VbString)
      )
      (setq row (1+ row))
       )
       (setq ctrow 2)
       (repeat (- (vla-get-rows table1) 2)
      (vla-setcellalignment Table1 ctrow 1 acmiddleleft)
      (setq ctrow (1+ ctrow))
       )
       (princ "Done")
      )
      (mapcar 'princ (list "\n There are not blocks references in " SpaceBkCt "."))
  )
  (vla-endundomark *adoc*)
  (prin1)
)
;;;/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Jue Oct 12, 2017 4:17 am

Me encontre esta rutina pero no la he probado
Saludos
Bernardo Corradine

; SUMLCAPA program, modified by Joshua M Orth. February 2000
; Modificado por InnerCity <itspanish@iespana.es> <http://www.iespana.es/itspanish/>


(defun C:sumlcapa ( / l suml en sumln)



(defun sumln ( / count ss1 e sxy exy)
(setq suml 0.0)
(if (=(type l)'STR)
(progn
(setq ss1 (ssget "_X" (list (cons 0 "LINE") (cons 8 l)))
count 0
)
(if ss1
(progn
(princ "\n")(princ(sslength ss1))(princ " lineas encontradas")
(princ "\nEspere, por favor ")
(repeat (sslength ss1)
(setq e (entget (ssname ss1 count))
sxy (cdr (assoc 10 e))
exy (cdr (assoc 11 e))
suml (+ suml (distance sxy exy))
count (1+ count)
)
)
)
(princ (strcat "\nNo se han encontrado lineas en la capa: " l))
)
)
)
)


(while (not (setq en (entsel "\nSelecciona la capa de trabajo: "))))
(setq l (cdr (assoc 8 (entget (car en)))))

(sumln)
(princ (strcat "\nLongitud total de las lineas: " (rtos suml)))
(princ)
)
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Jue Oct 12, 2017 4:22 am

y en este sitio dejo una rutina pero esta compilada
Espero te sirva
Saludos
Bernardo Corradine

https://we.tl/wZgAGcwV8J
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Jue Oct 12, 2017 4:24 am

Y me encontre otra mas, pero no la he probado

; Escrive un fichero.txt con nombre de capa y longitud de polilineas.

(defun eleva_polilinea (pol num) (entmod (sustituye_datos 38 num (entget pol))))

(defun std-sslist (ss / n lst)
(if (eq 'pickset (type ss))
(repeat (setq n (fix (sslength ss)))
(setq lst (cons (ssname ss (setq n (1- n))) lst))
)
)
)
(defun sustituye_datos (nume nuevo lista)
(subst (cons nume nuevo) (assoc nume lista) lista)
)

(defun lonobj (ent / enobj)
(setq enobj (vlax-ename->vla-object ent))
(vlax-curve-getdistatparam enobj (vlax-curve-getendparam enobj))
)
(defun c:LPL (/ ar alt)
(setq ar (open (strcat (getvar "DWGPREFIX") "Longtitud.txt") "W"))
(foreach pl (std-sslist (ssget '((0 . "LWPOLYLINE"))))
(setq alt (cdr (assoc 8 (entget pl))))
(eleva_polilinea pl (atof alt))
(write-line (strcat "Z=" alt "\tLargo=" (rtos (lonobj pl) 2 2)) ar)
)
(close ar)
(princ)
)
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Jue Oct 12, 2017 4:26 am

Y otra mas

(defun suma-linpol ()
(initget "Capa Seleccion")
(setq opt (getkword "\nSumar por [Capa/Seleccion] <Seleccion>: "))
(if (= opt nil)
(setq opt "Seleccion")
)
(if (= opt "Seleccion")
(progn
(setq lineas (ssget))
(setq polilineas lineas)
(progn
(setq m-lin (sslength lineas)
m 0
)
(setq objlin 0)
(repeat m-lin
(setq nombre (ssname lineas m))
(if (= "LINE" (cdr (assoc 0 (entget nombre))))
(progn
(setq p1 (cdr (assoc 10 (entget nombre)))
p2 (cdr (assoc 11 (entget nombre)))
)
(setq distancia-l (distance p1 p2))
(setq lst-distancia (cons distancia-l lst-distancia))
(setq objlin (1+ objlin))
)
)
(setq m (1+ m))
)
(setq lonlin-total (apply '+ lst-distancia))
) ;_progn
(progn
(setq n-pol (sslength polilineas)
n 0
)
(setq objpol 0)
(repeat n-pol
(setq nombre (ssname polilineas n))
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
(progn
(command "_.area" "_o" nombre)
(setq lon (getvar "perimeter"))
(setq longitud (cons lon longitud))
(setq objpol (1+ objpol))
)
)
(setq n (1+ n))
)
(setq lonpol-total (apply '+ longitud))
(alert (strcat "("(rtos n-pol 2 0)")"
" Objetos seleccionados"
"\n______________________________ "
"\n\n "
"("(rtos objlin 2 0)")"
" Líneas"
"\n\t"
(rtos lonlin-total 2 3)
" unid."
"\n\n "
"("(rtos objpol 2 0)")"
" Polilíneas"
"\n\t"
(rtos lonpol-total 2 3)
" unid."
"\n______________________________ "
"\n\n"
"TOTAL "
"("(rtos (+ objlin objpol) 2 0)")"
" Líneas + Polilíneas"
"\n\n "
(rtos (+ lonlin-total lonpol-total) 2 3)
" unid."
"\n\n"
)
)
) ;_progn
) ;_prong
(progn
(setq sel-capa
(cdr
(assoc 8
(entget (car (entsel "\nSeleccione Objeto: ")))
)
)
)
(setq lineas
(ssget "_x"
(list '(0 . "LINE") (cons 8 sel-capa))
)
)
(if (/= lineas nil)
(progn
(setq m-lin (sslength lineas)
m 0
)
(setq objlin 0)
(repeat m-lin
(setq nombre (ssname lineas m))
(if (= "LINE" (cdr (assoc 0 (entget nombre))))
(progn
(setq p1 (cdr (assoc 10 (entget nombre)))
p2 (cdr (assoc 11 (entget nombre)))
)
(setq distancia-l (distance p1 p2))
(setq lst-distancia (cons distancia-l lst-distancia))
(setq objlin (1+ objlin))
)
)
(setq m (1+ m))
)
(setq lonlin-total (apply '+ lst-distancia))
) ;_progn
(progn
(setq lonlin-total 0)
(setq objlin 0)
)
) ;_if
(progn
(setq polilineas
(ssget "_x"
(list '(0 . "LWPOLYLINE") (cons 8 sel-capa))
)
)
(if (/= polilineas nil)
(progn
(setq n-pol (sslength polilineas)
n 0
)
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Jue Oct 12, 2017 4:31 am

Hola, que tal bernie67, probe tu primera rutina y suma todas las lineas de una capa, solo que yo estoy buscando es:

Tengo Líneas que están en diferentes capas, quisiera poder hacer seleccion de un grupo de lineas de diversas capas y que esto me genere a la vez un cuadro donde me indiquen las sumas de las longitudes de líneas o polilíneas selecionadas por capas.

Ejemplo (Pero solo de lo que selecciono)
Cuadro
Capa 01 = Linea y Polilinea 45.50
Capa 02 = Linea y Polilinea 25.37
Capa 03 = Linea y Polilinea 17.65

https://drive.google.com/open?id=0B131sP2Zq1-QUWJGMWRGRG9XWUU

Código:

;:::::::::::::::::::: RECOPILACION DE LISP's PARA MEDICIONES (2/03/2004):::::::::::::::::::::::::::::
;********************************* CAMINO CONSECUTIVO **********************************
;Modificado por InnerCity <itspanish@iespana.es> <http://www.iespana.es/itspanish/>

(defun c:sumcam ()
 (setvar "cmdecho" 0)
 (graphscr)
 (setq
  p1 (getpoint "\nSelecciona el primer punto: ")
  p2 (getpoint p1 "\nSelecciona el siguiente punto: ")
  d1 (distance p1 p2)
  prdist (strcat "\nDistancia inicial: " (rtos d1))
 )
 (princ prdist)
 (setq p3 (getpoint p2 "\nSelecciona el siguiente punto o ENTER para acabar"))
 (while p3
  (setq
   d0 (distance p2 p3)
   d1 (+ (distance p2 p3) d1)
   p2 p3
   prdist (strcat "\nDistancia parcial: " (rtos d0) ", Distancia acumulada: " (rtos d1))
  )
  (princ prdist)
  (setq p3 (getpoint p2 "\nSelecciona el siguiente punto o ENTER para acabar: "))
 )
 (setq cumd (strcat "Distancia total: " (rtos d1)))
 (prompt cumd)
 (princ)
)

    
;********************************* CAMINO NO CONSECUTIVO ********************************
;Running distance calculator
;Modificado por InnerCity <itspanish@iespana.es> <http://www.iespana.es/itspanish/>

(defun c:sumcnc (/ pt1 pt2 d0 d1 )
  (graphscr)
  (setvar "CMDECHO" 0)
  (setq pt1 (getpoint " Selecciona el primer punto: "))(terpri)
  (setq pt2 (getpoint " Selecciona el siguiente punto: " pt1))(terpri)
  (setq d1 (distance pt1 pt2))
  (prompt " Distancia inicial: ")(prompt (rtos d1 2 4))      
    (while
    (setq pt1 (getpoint "\nSelecciona el siguiente primer punto o ENTER para acabar: " )) (terpri)
    (setq pt2 (getpoint " Selecciona el siguiente punto: " pt1 )) (terpri)
    (setq d0 (distance pt1 pt2))
    (setq d1 (+ (distance pt1 pt2) d1))
    (prompt "Distancia parcial: ")(prompt (rtos d0 2 4))(prompt " Distancia acumulada: ")(prompt (rtos d1 2 4))
  )
  (prompt "Distancia total: ")(prompt (rtos d1 2 4))
  (princ)
)

; ----------------------------------------------------------------------
;               (Returns the sum of selected arc objects)
;            Copyright (C) 1998 DotSoft, All Rights Reserved
; ----------------------------------------------------------------------


(defun c:sumarco ()
  (setq tlen 0.0)
  (setq sset (ssget '((0 . "ARC"))))
  (setq num (sslength sset) itm 0)
  (while (< itm num)
    (setq hnd (ssname sset itm))
    (setq ent (entget hnd))
    (setq rads (cdr (assoc 40 ent)))
    (setq sang (cdr (assoc 50 ent)))
    (setq eang (cdr (assoc 51 ent)))
    (if (> eang sang)
      (setq iang (- eang sang))
      (setq iang (+ (- 6.28319 sang) eang))
    )
    (setq larc (* iang rads))
    (setq tlen (+ tlen larc))
    (setq itm (1+ itm))
  )
  (princ (strcat "\nLongitud Total: " (rtos tlen)))
  (princ)
)

; ----------------------------------------------------------------------
;               (Returns the sum of selected line objects)
;            Copyright (C) 1997 DotSoft, All Rights Reserved
; ----------------------------------------------------------------------

; Para lineas con diferente cota en sus extremos se tomara la longitud real (3D Longitud), no la proyectada.

(defun C:sumlinea ()
  (setq sset (ssget '((0 . "LINE"))))
  (if sset
    (progn
      (setq tot 0.0)
      (setq num (sslength sset) itm 0)
      (while (< itm num)
        (setq hnd (ssname sset itm))
        (setq ent (entget hnd))
        (setq pt1 (cdr (assoc 10 ent)))
        (setq pt2 (cdr (assoc 11 ent)))
        (setq dis (distance pt1 pt2))
        (setq tot (+ tot dis))
        (setq itm (1+ itm))
      )
      (princ (strcat "\nLongitud Total: " (rtos tot)))
    )
  )
  (princ)
)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Written by Joshua M Orth. February 2000
; Modificado por InnerCity <itspanish@iespana.es> <http://www.iespana.es/itspanish/>


(defun C:sumlp (/ p l e sxy exy sum1 sum2 sum3)
   (setq p  (ssget   (list (cons -4 "<or")
                              (cons 0 "LINE")
                              (cons 0 "LWPOLYLINE")
                              (cons -4 "<and")
                                 (cons 0 "POLYLINE")
                                 (cons -4 "<not")
                                    (cons -4 "&") (cons 70 (+ 16 32 64))
                                 (cons -4 "not>")
                              (cons -4 "and>")
                           (cons -4 "or>")
                     )
            )
         sum1 0.0
         sum2 0.0
         sum3 0.0
   )
   ;check for null selection set
   (if p
      (progn
         (setq l 0)
         (repeat (sslength p)
            (cond
               ((= "LINE" (cdr (assoc 0 (setq e (entget (ssname p l))))))
                  (setq sxy (cdr (assoc 10 e))
                        exy (cdr (assoc 11 e))
                        sum1 (+ sum1 (distance sxy exy))
                  )
                  (terpri)
               )
               ((= "LWPOLYLINE" (cdr (assoc 0 (entget (setq e (ssname p l))))))
                  (command "_.area" "_E" e)
                  (setq sum2 (+ sum2 (getvar "perimeter")))
                  (terpri)
               )
               ((= "POLYLINE" (cdr (assoc 0 (entget (setq e (ssname p l))))))
                  (command "_.area" "_E" e)
                  (setq sum2 (+ sum2 (getvar "perimeter")))
                  (terpri)
               )
            )
            (setq l (1+ l))
         )
         (setq sum3 (+ sum1 sum2))
         (princ "\nLa suma total de longitudes para lineas es: ")
         (princ (rtos sum1))
         (princ "\nLa suma total de longitudes para polilineas es: ")
         (princ (rtos sum2))
         (princ "\nLa suma total de longitudes para lineas y/o polilineas es: ")
         (princ (rtos sum3))
      )
      (princ "\nNo has seleccionado ninguna linea o polilinea")
   )
   (princ)
)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Suma el area y perimetro de distintas polilineas mediante seleccion directa
; Written by Joshua M Orth. February 2000
; Readaptado por InnerCity <itspanish@iespana.es> <http://www.iespana.es/itspanish/>


(defun C:sumarea (/ p l e sum1 sum2)
   (setq p  (ssget   (list (cons -4 "<or")
                              (cons 0 "LWPOLYLINE")
                              (cons -4 "<and")
                                 (cons 0 "POLYLINE")
                                 (cons -4 "<not")
                                    (cons -4 "&") (cons 70 (+ 16 32 64))
                                 (cons -4 "not>")
                              (cons -4 "and>")
                           (cons -4 "or>")
                     )
            )
         sum1 0.0
         sum2 0.0
   )
   ;check for null selection set
   (if p
      (progn
         (setq l 0)
         (repeat (sslength p)
            (cond
               ((= "LWPOLYLINE" (cdr (assoc 0 (entget (setq e (ssname p l))))))
                  (command "_.area" "_E" e)
                  (setq sum1 (+ sum1 (getvar "area")))
                  (setq sum2 (+ sum2 (getvar "perimeter")))
                  (terpri)
               )
               ((= "POLYLINE" (cdr (assoc 0 (entget (setq e (ssname p l))))))
                  (command "_.area" "_E" e)
                  (setq sum1 (+ sum1 (getvar "area")))
                  (setq sum2 (+ sum2 (getvar "perimeter")))
                  (terpri)
               )
            )
            (setq l (1+ l))
         )
         (princ "\nLa suma total de perimetros/longitudes es: ")
         (princ (rtos sum2))
         (princ "\nLa suma total de areas es: ")
         (princ (rtos sum1))
      )
      (princ "\nNo has seleccionado ninguna polilinea")
   )
   (princ)
)

::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
; SUMLCAPA program, modified by Joshua M Orth. February 2000
; Modificado por InnerCity <itspanish@iespana.es> <http://www.iespana.es/itspanish/>


(defun C:sumlcapa ( / l suml en sumln)



   (defun sumln ( / count ss1 e sxy exy)
      (setq suml 0.0)
      (if (=(type l)'STR)
         (progn
            (setq ss1 (ssget "_X" (list (cons 0 "LINE") (cons 8 l)))
                  count 0
            )
            (if ss1
               (progn
                  (princ "\n")(princ(sslength ss1))(princ " lineas encontradas")
                  (princ "\nEspere, por favor ")
                  (repeat (sslength ss1)
                     (setq e (entget (ssname ss1 count))
                           sxy (cdr (assoc 10 e))
                           exy (cdr (assoc 11 e))
                           suml (+ suml (distance sxy exy))
                           count (1+ count)
                     )
                  )
               )
               (princ (strcat "\nNo se han encontrado lineas en la capa: " l))
            )
         )
      )
   )


   (while (not (setq en (entsel "\nSelecciona la capa de trabajo: "))))
   (setq l (cdr (assoc 8 (entget (car en)))))

   (sumln)
   (princ (strcat "\nLongitud total de las lineas: " (rtos suml)))
   (princ)
)

;********************************* HOLA CARACOLA ********************************


(prompt "\n*** Conjunto de rutinas para mediciones correctamente cargadas ***")
(prin1)


Esto encontre buscando en la web,

Instrucciones de Rutina

sta es una coleccion de rutinas en AutoLisp para Autocad, especialmente utiles para mediciones (suma de propiedades de numerosos elementos de Autocad).
No son de mi creacion, sino que las he recopilado y reunido en un solo *.lsp, aunque algunas se han traducido, otras modificado y otras readaptado.
Espero os sean de utilidad.

La lista de comandos asi como la funcion que realizan es esta:

*COMANDO: sumcam
Suma distancias consecutivamente entre puntos que se pediran en pantalla

*COMANDO: sumcnc
Suma distancias no necesariamente entre puntos consecutivos, los cuales se pediran en pantalla

*COMANDO: sumarco
Suma las longitudes de un numero indeterminado de arcos que se pediran en pantalla

*COMANDO: sumlinea
Suma las longitudes de un numero indeterminado de lineas que se pediran en pantalla
Para lineas con diferente cota en sus extremos se tomara la longitud real (3D Longitud), no la proyectada.

*COMANDO: sumlp
Suma las longitudes de un numero indeterminado de lineas y/o polilineas que se pediran en pantalla. Se expresa el resultado descompuesto segun lineas, polilineas y suma total de lineas mas polilineas.

*COMANDO: sumarea
Suma las areas y perimetros/longitudes de un numero indeterminado de polilineas (no necesariamente cerradas) que se pediran en pantalla

*COMANDO: sumlcapa
Suma las longitudes de todas las lineas de una capa cuya seleccion se hara mediante la designacion de cualquier objeto (linea o no) que pertenezca a esa capa. La capa puede tener otros objetos ademas de lineas, pero solo se sumara la longitud de estas.
NOTA: Se ha intentado hacer lo mismo con las areas pero no ha habido manera :((((((

INSTRUCCIONES: Para hacerlo funcionar (cargandose automaticamente cada vez que se inicie Autocad) colocais el archivo mediciones.LSP en cualquier carpeta. Despues, dentro de Autocad, os vais a 'Herramientas/Autolisp/Cargar', y en el menu que os salga os vais al cuadradito 'Cargar al inicio' y pulsais en 'Contenido'. En el proximo menu le dais a 'Añadir' y os sale una ventana de explorador desde la que seleccionareis el archivo alli donde lo tengais. Una vez seleccionado, pulsais 'Añadir', 'Cerrar' y listo. Los comandos se han de escribir directamente en la linea de comandos.
Si solo quieres usar el lisp ocasionalmente, no tienes mas que seleccionarlo desde el explorador de Windows y arrastrarlo y soltarlo sobre el dibujo en el que estes trabajando. Haciendo esto se cargara solo y unicamente se ejecutara en ese dibujo en concreto.

AGRADECIMIENTOS: a Rodanas y d5mac por algunos de los lisp originales.


Última edición por Zicaryd el Jue Oct 12, 2017 5:26 am, editado 1 vez

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Jue Oct 12, 2017 4:40 am

bernie67 escribió:Y me encontre otra mas, pero no la he probado

; Escrive un fichero.txt con nombre de capa y longitud de polilineas.

(defun eleva_polilinea (pol num) (entmod (sustituye_datos 38 num (entget pol))))

(defun std-sslist (ss / n lst)
  (if (eq 'pickset (type ss))
     (repeat (setq n (fix (sslength ss)))
        (setq lst (cons (ssname ss (setq n (1- n))) lst))
     )
  )
)
(defun sustituye_datos (nume nuevo lista)
  (subst (cons nume nuevo) (assoc nume lista) lista)
)

(defun lonobj (ent / enobj)
  (setq enobj (vlax-ename->vla-object ent))
  (vlax-curve-getdistatparam enobj (vlax-curve-getendparam enobj))
)
(defun c:LPL (/ ar alt)
  (setq ar (open (strcat (getvar "DWGPREFIX") "Longtitud.txt") "W"))
  (foreach pl (std-sslist (ssget '((0 . "LWPOLYLINE"))))
     (setq alt (cdr (assoc 8 (entget pl))))
     (eleva_polilinea pl (atof alt))
     (write-line (strcat "Z=" alt "\tLargo=" (rtos (lonobj pl) 2 2)) ar)
  )
  (close ar)
  (princ)
)

Esta rutina podria servir, pero necesitaria que me ayuden, ya que esta no selecciona lineas, y podria ser mejor si las sumara.
Ojala me puedan apoyar.

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Jue Oct 12, 2017 5:24 am

bernie67 escribió:Y otra mas

(defun suma-linpol ()
 (initget "Capa Seleccion")
 (setq opt (getkword "\nSumar por [Capa/Seleccion] <Seleccion>: "))
 (if (= opt nil)
   (setq opt "Seleccion")
 )
 (if (= opt "Seleccion")
   (progn
     (setq lineas (ssget))
     (setq polilineas lineas)
(progn
 (setq m-lin (sslength lineas)
m     0
 )
 (setq objlin 0)
 (repeat m-lin
   (setq nombre (ssname lineas m))
   (if (= "LINE" (cdr (assoc 0 (entget nombre))))
     (progn
(setq p1 (cdr (assoc 10 (entget nombre)))
     p2 (cdr (assoc 11 (entget nombre)))
)
(setq distancia-l (distance p1 p2))
(setq lst-distancia (cons distancia-l lst-distancia))
(setq objlin (1+ objlin))
     )
   )
   (setq m (1+ m))
 )
 (setq lonlin-total (apply '+ lst-distancia))
) ;_progn
(progn
 (setq n-pol (sslength polilineas)
n     0
 )
 (setq objpol 0)
 (repeat n-pol
   (setq nombre (ssname polilineas n))
   (if (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
     (progn
(command "_.area" "_o" nombre)
(setq lon (getvar "perimeter"))
(setq longitud (cons lon longitud))
(setq objpol (1+ objpol))
     )
   )
   (setq n (1+ n))
 )
 (setq lonpol-total (apply '+ longitud))
 (alert (strcat "("(rtos n-pol 2 0)")"
"  Objetos seleccionados"
"\n______________________________   "
"\n\n      "
"("(rtos objlin 2 0)")"
"  Líneas"
"\n\t"
(rtos lonlin-total 2 3)
"  unid."
"\n\n      "
"("(rtos objpol 2 0)")"
"  Polilíneas"
"\n\t"
(rtos lonpol-total 2 3)
"  unid."
"\n______________________________   "
"\n\n"
"TOTAL  "
"("(rtos (+ objlin objpol) 2 0)")"
"  Líneas + Polilíneas"
"\n\n      "
(rtos (+ lonlin-total lonpol-total) 2 3)
"  unid."
"\n\n"
)
 )
) ;_progn
   ) ;_prong
   (progn
     (setq sel-capa
    (cdr
      (assoc 8
     (entget (car (entsel "\nSeleccione Objeto: ")))
      )
    )
     )
     (setq lineas
    (ssget "_x"
   (list '(0 . "LINE") (cons 8 sel-capa))
    )
     )
     (if (/= lineas nil)
(progn
 (setq m-lin (sslength lineas)
m     0
 )
 (setq objlin 0)
 (repeat m-lin
   (setq nombre (ssname lineas m))
   (if (= "LINE" (cdr (assoc 0 (entget nombre))))
     (progn
(setq p1 (cdr (assoc 10 (entget nombre)))
     p2 (cdr (assoc 11 (entget nombre)))
)
(setq distancia-l (distance p1 p2))
(setq lst-distancia (cons distancia-l lst-distancia))
(setq objlin (1+ objlin))
     )
   )
   (setq m (1+ m))
 )
 (setq lonlin-total (apply '+ lst-distancia))
) ;_progn
       (progn
 (setq lonlin-total 0)
         (setq objlin 0)
)
     ) ;_if
   (progn
     (setq polilineas
    (ssget "_x"
   (list '(0 . "LWPOLYLINE") (cons 8 sel-capa))
    )
     )
     (if (/= polilineas nil)
(progn
 (setq n-pol (sslength polilineas)
n     0
 )

Este codigo esta erroneo, y no corre, lo busque y aca lo coloco completo, pero igual suma por seleccion pero no me da longitud por capa.

Código:

(defun suma-linpol   ()
  (initget "Capa Seleccion")
  (setq opt (getkword "\nSumar por [Capa/Seleccion] <Seleccion>: "))
  (if (= opt nil)
    (setq opt "Seleccion")
  )
  (if (= opt "Seleccion")
    (progn
      (setq lineas (ssget))
      (setq polilineas lineas)
   (progn
     (setq   m-lin (sslength lineas)
      m    0
     )
     (setq objlin 0)
     (repeat m-lin
       (setq nombre (ssname lineas m))
       (if   (= "LINE" (cdr (assoc 0 (entget nombre))))
         (progn
      (setq p1 (cdr (assoc 10 (entget nombre)))
            p2 (cdr (assoc 11 (entget nombre)))
      )
      (setq distancia-l (distance p1 p2))
      (setq lst-distancia (cons distancia-l lst-distancia))
      (setq objlin (1+ objlin))
         )
       )
       (setq m (1+ m))
     )
     (setq lonlin-total (apply '+ lst-distancia))
   ) ;_progn
   (progn
     (setq   n-pol (sslength polilineas)
      n    0
     )
     (setq objpol 0)
     (repeat n-pol
       (setq nombre (ssname polilineas n))
       (if   (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
         (progn
      (command "_.area" "_o" nombre)
      (setq lon (getvar "perimeter"))
      (setq longitud (cons lon longitud))
      (setq objpol (1+ objpol))
         )
       )
       (setq n (1+ n))
     )
     (setq lonpol-total (apply '+ longitud))
     (alert (strcat "("(rtos n-pol 2 0)")"
          "  Objetos seleccionados"
          "\n______________________________  "
          "\n\n      "
          "("(rtos objlin 2 0)")"
          "  Líneas"
          "\n\t"
          (rtos lonlin-total 2 3)
          "  unid."
          "\n\n      "
          "("(rtos objpol 2 0)")"
          "  Polilíneas"
          "\n\t"
          (rtos lonpol-total 2 3)
          "  unid."
          "\n______________________________  "
          "\n\n"
          "TOTAL  "
          "("(rtos (+ objlin objpol) 2 0)")"
          "  Líneas + Polilíneas"
          "\n\n      "
          (rtos (+ lonlin-total lonpol-total) 2 3)
          "  unid."
          "\n\n"
       )
     )
   ) ;_progn
    ) ;_prong
    (progn
      (setq sel-capa
       (cdr
         (assoc 8
            (entget (car (entsel "\nSeleccione Objeto: ")))
         )
       )
      )
      (setq lineas
       (ssget "_x"
          (list '(0 . "LINE") (cons 8 sel-capa))
       )
      )
      (if (/= lineas nil)
   (progn
     (setq   m-lin (sslength lineas)
      m    0
     )
     (setq objlin 0)
     (repeat m-lin
       (setq nombre (ssname lineas m))
       (if   (= "LINE" (cdr (assoc 0 (entget nombre))))
         (progn
      (setq p1 (cdr (assoc 10 (entget nombre)))
            p2 (cdr (assoc 11 (entget nombre)))
      )
      (setq distancia-l (distance p1 p2))
      (setq lst-distancia (cons distancia-l lst-distancia))
      (setq objlin (1+ objlin))
         )
       )
       (setq m (1+ m))
     )
     (setq lonlin-total (apply '+ lst-distancia))
   ) ;_progn
        (progn
     (setq lonlin-total 0)
          (setq objlin 0)
   )
      ) ;_if
    (progn
      (setq polilineas
       (ssget "_x"
          (list '(0 . "LWPOLYLINE") (cons 8 sel-capa))
       )
      )
      (if (/= polilineas nil)
   (progn
     (setq   n-pol (sslength polilineas)
      n    0
     )
     (setq objpol 0)
     (repeat n-pol
       (setq nombre (ssname polilineas n))
       (if   (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
         (progn
      (command "_.area" "_o" nombre)
      (setq lon (getvar "perimeter"))
      (setq longitud (cons lon longitud))
      (setq objpol (1+ objpol))
         )
       )
       (setq n (1+ n))
     )
     (setq lonpol-total (apply '+ longitud))

   ) ;_progn
        (progn
     (setq lonpol-total 0)
          (setq objpol 0)
   )
      ) ;_if
     (alert (strcat "Capa  "
          "\""
          sel-capa
          "\""
          "\n______________________________  "
          "\n\n      "
          "("(rtos objlin 2 0)")"
          "  Líneas"
          "\n\t"
          (rtos lonlin-total 2 3)
          "  unid."
          "\n\n      "
          "("(rtos objpol 2 0)")"
          "  Polilíneas"
          "\n\t"
          (rtos lonpol-total 2 3)
          "  unid."
          "\n______________________________  "
          "\n\n"
          "TOTAL  "
          "("(rtos (+ objlin objpol) 2 0)")"
          "  Líneas + Polilíneas"
          "\n\n      "
          (rtos (+ lonlin-total lonpol-total) 2 3)
          "  unid."
          "\n\n"
       )
     )
      ) ;_progn
    ) ;_progn
  ) ;_if
)

(defun c:sulipo   (/      tipo      polilineas   lineas
       n-pol      n      m-lin      m
       nombre      lon      longitud   linpol
       lonlin-total   lonpol-total   p1      p2
       distancia-l   lst-distancia   opt      sel-capa
      )
  (setvar "cmdecho" 0)
  (suma-linpol)
  (setvar "cmdecho" 1)
  (prin1)
)

(prompt "\n*** nuevo comando SuLiPo definido. ***")
(prin1)

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Jue Oct 12, 2017 5:50 am

bernie67 escribió:y en este sitio dejo una rutina pero esta compilada
Espero te sirva
Saludos
Bernardo Corradine

https://we.tl/wZgAGcwV8J

Esta rutina, se aproxima con lo que quiero, pero cuando seleciono una parte, igual me general el cuadro por del Total de lineas y no respeta la seleccion.

Lo he subido a esta ruta, ya que el Wetranfer solo dura unos pocos dias en la nube.
https://drive.google.com/open?id=0B131sP2Zq1-QMC04dnhCN3ZrQ2s

Esperando que alguien me pueda apoyar con lo requerido

Saludos.

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Jue Oct 12, 2017 5:07 pm

Pues Zicaryd lamento no haberte ayudado mas a encontrar la solución a lo que deseas. Yo solo soy usuario, y de programación nada, aparte de almacenar rutinas. Esperemos que alguno de los compañeros de foro te pueda ayudar.
Saludos
Bernardo Corradine M
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por nolo el Jue Oct 12, 2017 7:17 pm

A ver Zicarid, si tu problema es obtener un listado de longitudes totales separadas por capas, es casi inmediato y sin vlisp

Código:
(defun c:ytal(/ ss sl capas largos)
(if (progn
 (princ (strcat (chr 10)"Seleccionar líneas :"))
 (setq ss (ssget '((0 . "*LINE"))))
 )
(progn
(setq sl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
 capas '()
 largos '()
)
(foreach a sl
 (command "_LENGTHEN" a"")
 (if (member (setq c (cdr(assoc 8 (entget a)))) (mapcar 'car capas))
 (setq capas (mapcar '(lambda(x)
 (if (= (car x)c) (append x (list(getvar 'perimeter))) x)
 )capas))
 (setq capas (cons (list c (getvar 'perimeter)) capas)))
)
(setq largos (mapcar '(lambda(a)
 (strcat (chr 10)(car a) " "(rtos (apply '+ (cdr a)) 2 2))
) capas))
(mapcar 'princ largos)
)
(princ (strcat (chr 10) "No hay selección ..."))
)
(princ)
)

Pero si lo que quieres es una tabla dentro del dwg (de la que no has puesto ejemplo), a mi me llevaría bastante tiempo el darle formato, así que te sugiero que copies el resultado de la rutina de la pantalla de texto (F2) en el portapapeles y lo pegues donde quieras.

Un saludo

Pd Dejo los resultados parciales en la lista capas y los totales en la lista largos por si alguien se anima a meterle mano a lo de la tabla

nolo

Mensajes : 131
Fecha de inscripción : 17/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Vie Oct 13, 2017 1:52 am

Que tal amigo nolo, disculpa corri la rutina pero me sale un error y se cancela, te copio lo que sale, ojala le puedas dar una mirada, por otro lado solo un relacion simple indicando la capa y la suma de los perimetro "lines y polilineas" pero solo de lo que selecciono.


Tipo 01 = 132.50
Tipo 02 = 789.60
Tipo 03 = 1687.23

Pd. error

Command: YTAL

Seleccionar líneas :
Select objects: Specify opposite corner: 52 found

Select objects:
_LENGTHEN
Select an object to measure or [DElta/Percent/Total/DYnamic] <Total>:

Current length: 45.8941
Select an object to measure or [DElta/Percent/Total/DYnamic] <Total>:
Specify total length or [Angle] <1.0000>: _LENGTHEN
Requires numeric distance, two points, or option keyword.
; error: Function cancelled

Specify total length or [Angle] <1.0000>:

Select an object to change or [Undo]: *Cancel*


Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por nolo el Vie Oct 13, 2017 11:56 am

Pues esto es lo que pasa cuando utilizas los command que en cada máquina funcionan distinto dependiendo de la configuración del usuario
A ver ahora con vlisp
Código:
(defun c:ytal2(/ ss sl capas largos lon)
(vl-load-com)
(if (progn
 (princ (strcat (chr 10)"Seleccionar líneas :"))
 (setq ss (ssget '((0 . "*LINE"))))
 )
(progn
(setq sl (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss)))
 capas '()
 largos '()
)
(foreach a sl
 (setq lon (vlax-get-property (vlax-ename->vla-object a) 'length))
 ;;(command "_LENGTHEN" a"") (setq lon (getvar 'perimeter))
 (if (member (setq c (cdr(assoc 8 (entget a)))) (mapcar 'car capas))
 (setq capas (mapcar '(lambda(x)
 (if (= (car x)c) (append x (list lon)) x)
 )capas))
 (setq capas (cons (list c lon) capas)))
)
(setq largos (mapcar '(lambda(a)
 (strcat (chr 10)(car a) " = "(rtos (apply '+ (cdr a)) 2 2))
) capas))
(mapcar 'princ largos)
)
(princ (strcat (chr 10) "No hay selección ..."))
)
(princ)
)

Un saludo

nolo

Mensajes : 131
Fecha de inscripción : 17/03/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Vie Oct 13, 2017 12:58 pm

Nolo
Gracias estimado por el tiempo dedicado, y tambien a la gente que contribuye de una u otra forma en el foro.

Saludos.

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Sáb Oct 14, 2017 2:10 am

(defun suma-linpol ()
(initget "Capa Seleccion")
(setq opt (getkword "\nSumar por [Capa/Seleccion] <Seleccion>: "))
(if (= opt nil)
(setq opt "Seleccion")
)
(if (= opt "Seleccion")
(progn
(setq lineas (ssget))
(setq polilineas lineas)
(progn
(setq m-lin (sslength lineas)
m 0
)
(setq objlin 0)
(repeat m-lin
(setq nombre (ssname lineas m))
(if (= "LINE" (cdr (assoc 0 (entget nombre))))
(progn
(setq p1 (cdr (assoc 10 (entget nombre)))
p2 (cdr (assoc 11 (entget nombre)))
)
(setq distancia-l (distance p1 p2))
(setq lst-distancia (cons distancia-l lst-distancia))
(setq objlin (1+ objlin))
)
)
(setq m (1+ m))
)
(setq lonlin-total (apply '+ lst-distancia))
) ;_progn
(progn
(setq n-pol (sslength polilineas)
n 0
)
(setq objpol 0)
(repeat n-pol
(setq nombre (ssname polilineas n))
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
(progn
(command "_.area" "_o" nombre)
(setq lon (getvar "perimeter"))
(setq longitud (cons lon longitud))
(setq objpol (1+ objpol))
)
)
(setq n (1+ n))
)
(setq lonpol-total (apply '+ longitud))
(alert (strcat "("(rtos n-pol 2 0)")"
" Objetos seleccionados"
"\n______________________________ "
"\n\n "
"("(rtos objlin 2 0)")"
" Líneas"
"\n\t"
(rtos lonlin-total 2 3)
" unid."
"\n\n "
"("(rtos objpol 2 0)")"
" Polilíneas"
"\n\t"
(rtos lonpol-total 2 3)
" unid."
"\n______________________________ "
"\n\n"
"TOTAL "
"("(rtos (+ objlin objpol) 2 0)")"
" Líneas + Polilíneas"
"\n\n "
(rtos (+ lonlin-total lonpol-total) 2 3)
" unid."
"\n\n"
)
)
) ;_progn
) ;_prong
(progn
(setq sel-capa
(cdr
(assoc 8
(entget (car (entsel "\nSeleccione Objeto: ")))
)
)
)
(setq lineas
(ssget "_x"
(list '(0 . "LINE") (cons 8 sel-capa))
)
)
(if (/= lineas nil)
(progn
(setq m-lin (sslength lineas)
m 0
)
(setq objlin 0)
(repeat m-lin
(setq nombre (ssname lineas m))
(if (= "LINE" (cdr (assoc 0 (entget nombre))))
(progn
(setq p1 (cdr (assoc 10 (entget nombre)))
p2 (cdr (assoc 11 (entget nombre)))
)
(setq distancia-l (distance p1 p2))
(setq lst-distancia (cons distancia-l lst-distancia))
(setq objlin (1+ objlin))
)
)
(setq m (1+ m))
)
(setq lonlin-total (apply '+ lst-distancia))
) ;_progn
(progn
(setq lonlin-total 0)
(setq objlin 0)
)
) ;_if
(progn
(setq polilineas
(ssget "_x"
(list '(0 . "LWPOLYLINE") (cons 8 sel-capa))
)
)
(if (/= polilineas nil)
(progn
(setq n-pol (sslength polilineas)
n 0
)
(setq objpol 0)
(repeat n-pol
(setq nombre (ssname polilineas n))
(if (= "LWPOLYLINE" (cdr (assoc 0 (entget nombre))))
(progn
(command "_.area" "_o" nombre)
(setq lon (getvar "perimeter"))
(setq longitud (cons lon longitud))
(setq objpol (1+ objpol))
)
)
(setq n (1+ n))
)
(setq lonpol-total (apply '+ longitud))

) ;_progn
(progn
(setq lonpol-total 0)
(setq objpol 0)
)
) ;_if
(alert (strcat "Capa "
"\""
sel-capa
"\""
"\n______________________________ "
"\n\n "
"("(rtos objlin 2 0)")"
" Líneas"
"\n\t"
(rtos lonlin-total 2 3)
" unid."
"\n\n "
"("(rtos objpol 2 0)")"
" Polilíneas"
"\n\t"
(rtos lonpol-total 2 3)
" unid."
"\n______________________________ "
"\n\n"
"TOTAL "
"("(rtos (+ objlin objpol) 2 0)")"
" Líneas + Polilíneas"
"\n\n "
(rtos (+ lonlin-total lonpol-total) 2 3)
" unid."
"\n\n"
)
)
) ;_progn
) ;_progn
) ;_if
)

(defun c:sulipo (/ tipo polilineas lineas
n-pol n m-lin m
nombre lon longitud linpol
lonlin-total lonpol-total p1 p2
distancia-l lst-distancia opt sel-capa
)
(setvar "cmdecho" 0)
(suma-linpol)
(setvar "cmdecho" 1)
(prin1)
)

(prompt "\n*** nuevo comando SuLiPo definido. ***")
(prin1)
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por bernie67 el Sáb Oct 14, 2017 2:11 am

Probado en autocad 2018 en ingles
avatar
bernie67

Mensajes : 53
Fecha de inscripción : 22/03/2016
Edad : 50
Localización : Bogota DC-Colombia

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Zicaryd el Sáb Oct 14, 2017 5:32 am

Estimado ahora si ya esta completo, pero para mi caso no me ayuda mucho pero es muy buena la rutina, igual muchas gracias amigo bernie67

Saludos.

Pd. por ahy que se puede hacer un post como tema de Compartir rutinas Nivel Dios. Jajaja

Zicaryd

Mensajes : 19
Fecha de inscripción : 23/10/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Longitud de Lineas x Tipo

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Ver el tema anterior Ver el tema siguiente Volver arriba

- Temas similares

 
Permisos de este foro:
No puedes responder a temas en este foro.