23 jun 2009

Rutina cuenta bloques iguales de una misma capa


;|comando "blcont" cuenta bloques iguales a uno señalado
siempre que estén en la misma capa indicada.
****Prexem - 2009****
********************************************************|;
(defun C:blcont (/ cmdechant nomb lista cant)
(setq cmdechant (getvar "cmdecho"))
(setvar "cmdecho" 0)
(vl-load-com)
(setq ent (car (entsel "\nseleccione bloque a contar: ")))
(setq vle (vlax-ename->vla-object ent))
(setq nomb (vlax-get vle "name"))
(setq cap (vlax-get vle "layer"))
(setq
lista (ssget "_x"
(list (cons 0 "INSERT") (cons 2 nomb) (cons 8 cap))
)
)
(setq cant (sslength lista))
(princ
(strcat "\nCantidad de bloques con nombre " nomb ": ")
)
(princ cant)
(setvar "cmdecho" cmdechant)
(princ)
);;;fin

7 jul 2008

Rutina "long-tramos" obtiene las longitudes de los tramos de una polilínea indicada:


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; by (c) Prexem - Victor Adolfo Bracamonte - 2008 ;;;
;;; www.prexem.blogspot.com ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:long-tramos (/ errant *error* e vla-e
long i f v c cant
xp c1 yp zp p
lp rlp cantp p1
p2 d
)
(vl-load-com)
(defun errlongtramos (m) (prompt "\n*fin*"))
(setq errant *error*
*error* errlongtramos
)
(setq e
(car
(entsel
"\nseleccione polilinea a medir tramos:"
)
)
)
(if
(or
(equal (cdr (assoc 0 (entget e))) "POLYLINE")
(equal (cdr (assoc 0 (entget e))) "LWPOLYLINE")
)
(progn
(setq
vla-e (vlax-ename->vla-object e)
long (vlax-get vla-e 'length)
v (vlax-get vla-e 'coordinates)
)
(princ "\nLongitud total: ")
(princ long)
(setq c 0)
(setq cant (/ (length v) 2))
(repeat cant
(setq xp (nth c v)
c1 (1+ c)
yp (nth c1 v)
zp 0.0
p (list xp yp zp)
lp (cons p lp)
c (1+ c1)
)
)
(setq rlp (reverse lp))
(setq cantp (length rlp))
(setq c 0)
(repeat cantp
(setq p1 (nth c rlp))
(setq c1 (1+ c))
(setq p2 (nth c1 rlp))
(setq d (distance p1 p2))
(setq c (1+ c))
(princ "\ntramo ")
(princ c1)
(princ ": ")
(princ d)
)
)
(princ "\n*EL OBJETO INDICADO NO ES POLILINEA*")
)
(setq *error* errant)
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

21 jun 2008

Rutina "STN" sirve para sumar grupos de textos numéricos:


;|***********************************************
rutina "stn" suma textos numericos,
funciona con TEXT y MTEXT no editados
(No formateados).
***********************************************
(c) by Prexem - Victor Adolfo Bracamonte - 2008
**** www.prexem.blogspot.com ****
***********************************************|;
(defun c:stn (/ sel p h cant index e data val n listn sum res)
(prompt
"\nSeleccione textos numericos a sumar, que no hayan sido editados:"
)
(setq sel (ssget '((0 . "MTEXT,TEXT")))
p (getpoint
"\nDar punto de inserción para texto final:"
)
h (getdist p "\nDar altura de texto:")
cant (sslength sel)
index 0
);setq
(repeat cant
(setq e (ssname sel index)
data (entget e)
val (cdr (assoc 1 data))
n (atof val)
listn (cons n listn)
index (1+ index)
);setq
);repeat
(setq sum (apply '+ listn))
(setq res (rtos sum 2 2))
(command "_.text" p h 0 res)
(princ)
);defun
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

14 jun 2008

Rutina que sirve para cerrar grupos de polilíneas abiertas.


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:close-plines (/ sel cant index obj origen final)
(vl-load-com)
(prompt "****\nSeleccione polilineas a cerrar\n****")
(setq sel (ssget '((0 . "*POLYLINE")))
cant (sslength sel)
index 0
)
(repeat cant
(setq obj (ssname sel index))
(setq origen (vlax-curve-getstartpoint obj)
final (vlax-curve-getendpoint obj)
)
(if (equal origen final 0.001)
(alert "Pline cerrada....")
(command "_pedit" obj "_c" "")
);if
(setq index (1+ index))
);repeat
(princ)
);fin
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;