Acotar Polilínea
4 participantes
Página 1 de 1.
Acotar Polilínea
Saludos al Grupo,
Necesitaría ayuda con la siguiente rutina,
esta permite acotar todos los segmentos rectos de una polilínea y necesitaría que no solo acote de manera lineal, sino que lo haga con las entidades curvas.
Ya le quité al programa original las partes que me son innecesarias, pero mis conocimientos no me permiten completar las lineas de código para hacer lo que necesito.
El código original lo extraje de otro foro y pertenece a Sr. Lee Mac, el cual transcribo para quien le sea de utilidad.
Desde ya muchas gracias.
Necesitaría ayuda con la siguiente rutina,
- Código:
(defun c:dimpolygons ( / *error* mr_IsPointInside mid adoc sel lay d ts i lw enx pl lwn enxn plni plno plnom plm )
(vl-load-com)
(defun *error* ( m )
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
)
(defun mr_IsPointInside ( pt ptlst / trianglst ptinsidetriangle-p trl )
(defun trianglst ( ptlst / unique LM:ListClockwise-p clockwise-p l p1 p2 p3 trl )
(defun unique ( l )
(if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
)
;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented
(defun LM:ListClockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)
(defun clockwise-p ( p1 p2 p3 )
(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(setq l ptlst)
(while (> (length ptlst) 3)
(setq p1 (car ptlst) p2 (cadr ptlst) p3 (caddr ptlst))
(cond
( (LM:ListClockwise-p ptlst)
(if
(and
(clockwise-p p1 p2 p3)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
( (not (LM:ListClockwise-p ptlst))
(if
(and
(not (clockwise-p p1 p2 p3))
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
)
)
(setq trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl))
trl
)
(defun ptinsidetriangle-p ( pt p1 p2 p3 )
(and
(not
(or
(inters pt p1 p2 p3)
(inters pt p2 p1 p3)
(inters pt p3 p1 p2)
)
)
(not
(or
(> (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
(> (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
(> (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
)
)
)
)
(setq trl (trianglst ptlst))
(vl-some (function (lambda ( x ) (ptinsidetriangle-p pt (car x) (cadr x) (caddr x)))) trl)
)
(defun mid ( p1 p2 )
(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(prompt "\nSelect closed POLYGONS...")
(setq sel (ssget (list '(0 . "LWPOLYLINE") '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
(initget 7)
(setq d (getdist "\nPick or specify offset distance for dimensioning : "))
(if sel
(progn
(repeat (setq i (sslength sel))
(setq lw (ssname sel (setq i (1- i))))
(setq enx (entget lw))
(setq pl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enx))) lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enx))))
(vla-offset (vlax-ename->vla-object lw) d)
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
(if (not (mr_IsPointInside (car plni) pl))
(progn
(entdel lwn)
(vla-offset (vlax-ename->vla-object lw) (- d))
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
)
)
(entdel lwn)
(setq plno (mapcar (function (lambda ( a b ) (mapcar (function +) a (mapcar (function -) a b)))) pl plni))
(setq plnom (mapcar (function (lambda ( a b ) (mid a b))) plno (cdr (reverse (cons (car plno) (reverse plno))))))
(mapcar (function (lambda ( a b c ) (command "_.DIMALIGNED" "_non" a "_non" b "_non" c))) pl (cdr (reverse (cons (car pl) (reverse pl)))) plnom)
;_dimarc
)
)
(prompt "\nEmpty sel. set... Retry routine with valid sel. set...")
)
(*error* nil)
)
esta permite acotar todos los segmentos rectos de una polilínea y necesitaría que no solo acote de manera lineal, sino que lo haga con las entidades curvas.
Ya le quité al programa original las partes que me son innecesarias, pero mis conocimientos no me permiten completar las lineas de código para hacer lo que necesito.
El código original lo extraje de otro foro y pertenece a Sr. Lee Mac, el cual transcribo para quien le sea de utilidad.
- Código:
(defun c:dimpolygons ( / *error* mr_IsPointInside mid adoc sel lay d ts i lw enx pl lwn enxn plni plno plnom plm )
(vl-load-com)
(defun *error* ( m )
(if lay
(setvar 'clayer lay)
)
(vla-endundomark adoc)
(if m
(prompt m)
)
(princ)
)
(defun mr_IsPointInside ( pt ptlst / trianglst ptinsidetriangle-p trl )
(defun trianglst ( ptlst / unique LM:ListClockwise-p clockwise-p l p1 p2 p3 trl )
(defun unique ( l )
(if l (cons (car l) (unique (vl-remove-if (function (lambda ( x ) (equal x (car l) 1e-6))) l))))
)
;; List Clockwise-p - Lee Mac
;; Returns T if the point list is clockwise oriented
(defun LM:ListClockwise-p ( lst )
(minusp
(apply '+
(mapcar
(function
(lambda ( a b )
(- (* (car b) (cadr a)) (* (car a) (cadr b)))
)
)
lst (cons (last lst) lst)
)
)
)
)
(defun clockwise-p ( p1 p2 p3 )
(< (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
)
(setq l ptlst)
(while (> (length ptlst) 3)
(setq p1 (car ptlst) p2 (cadr ptlst) p3 (caddr ptlst))
(cond
( (LM:ListClockwise-p ptlst)
(if
(and
(clockwise-p p1 p2 p3)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
( (not (LM:ListClockwise-p ptlst))
(if
(and
(not (clockwise-p p1 p2 p3))
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p1 p2 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p2 p3 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
(= (length (unique (vl-remove nil (mapcar (function (lambda ( a b ) (inters p3 p1 a b))) l (cdr (reverse (cons (car l) (reverse l)))))))) 2)
)
(progn
(setq trl (cons (list p1 p2 p3) trl))
(setq ptlst (vl-remove p2 ptlst))
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
(setq ptlst (cdr (reverse (cons (car ptlst) (reverse ptlst)))))
)
)
)
)
(setq trl (cons (list (car ptlst) (cadr ptlst) (caddr ptlst)) trl))
trl
)
(defun ptinsidetriangle-p ( pt p1 p2 p3 )
(and
(not
(or
(inters pt p1 p2 p3)
(inters pt p2 p1 p3)
(inters pt p3 p1 p2)
)
)
(not
(or
(> (+ (distance pt p1) (distance pt p2)) (+ (distance p3 p1) (distance p3 p2)))
(> (+ (distance pt p2) (distance pt p3)) (+ (distance p1 p2) (distance p1 p3)))
(> (+ (distance pt p3) (distance pt p1)) (+ (distance p2 p3) (distance p2 p1)))
)
)
)
)
(setq trl (trianglst ptlst))
(vl-some (function (lambda ( x ) (ptinsidetriangle-p pt (car x) (cadr x) (caddr x)))) trl)
)
(defun mid ( p1 p2 )
(mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) p1 p2)
)
(vla-startundomark (setq adoc (vla-get-activedocument (vlax-get-acad-object))))
(prompt "\nSelect closed POLYGONS...")
(setq sel (ssget (list '(0 . "LWPOLYLINE") '(-4 . "&=") '(70 . 1) '(-4 . "<not") '(-4 . "<>") '(42 . 0.0) '(-4 . "not>"))))
(setq lay (getvar 'clayer))
(initget 7)
(setq d (getdist "\nPick or specify offset distance for dimensioning : "))
(setq ts (/ d 2.0))
(setvar 'dimtxsty "Standard")
(setvar 'dimjust 0)
(setvar 'dimtad 0)
(setvar 'dimtih 0)
(setvar 'dimupt 0)
(setvar 'dimtix 1)
(setvar 'dimtofl 1)
(setvar 'dimaunit 1)
(setvar 'dimlunit 2)
(setvar 'dimadec 1)
(setvar 'dimdec 2)
(setvar 'dimasz (/ ts 2.0))
(vla-put-height (vlax-ename->vla-object (tblobjname "STYLE" "Standard")) ts)
(if sel
(progn
(repeat (setq i (sslength sel))
(setq lw (ssname sel (setq i (1- i))))
(setq enx (entget lw))
(setq pl (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enx))) lw 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enx))))
(vla-offset (vlax-ename->vla-object lw) d)
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
(if (not (mr_IsPointInside (car plni) pl))
(progn
(entdel lwn)
(vla-offset (vlax-ename->vla-object lw) (- d))
(setq lwn (entlast))
(setq enxn (entget lwn))
(setq plni (mapcar (function (lambda ( x ) (trans (list (car x) (cadr x) (cdr (assoc 38 enxn))) lwn 1))) (mapcar (function cdr) (vl-remove-if (function (lambda ( x ) (/= (car x) 10))) enxn))))
)
)
(entdel lwn)
(setq plno (mapcar (function (lambda ( a b ) (mapcar (function +) a (mapcar (function -) a b)))) pl plni))
(setq plnom (mapcar (function (lambda ( a b ) (mid a b))) plno (cdr (reverse (cons (car plno) (reverse plno))))))
(if (not (tblsearch "LAYER" "DIMALIGNED"))
(command "_.-LAYER" "_M" "DIMALIGNED" "")
(progn
(command "_.-LAYER" "_T" "DIMALIGNED" "")
(setvar 'clayer "DIMALIGNED")
)
)
(mapcar (function (lambda ( a b c ) (command "_.DIMALIGNED" "_non" a "_non" b "_non" c))) pl (cdr (reverse (cons (car pl) (reverse pl)))) plnom)
(if (not (tblsearch "LAYER" "DIMANGULAR"))
(command "_.-LAYER" "_M" "DIMANGULAR" "")
(setvar 'clayer "DIMANGULAR")
)
(command "_.-LAYER" "_F" "DIMALIGNED" "")
(setq pl (reverse (cons (car pl) (reverse pl))))
(setq plm (mapcar (function (lambda ( a b ) (mid a b))) pl (cdr pl)))
(mapcar (function (lambda ( a b c d ) (command "_.DIMANGULAR" "" "_non" a "_non" b "_non" c "_non" d))) (cdr pl) plm (cdr (reverse (cons (car plm) (reverse plm)))) (cdr (reverse (cons (car plni) (reverse plni)))))
)
(command "_.-LAYER" "_T" "DIMALIGNED" "")
)
(prompt "\nEmpty sel. set... Retry routine with valid sel. set...")
)
(*error* nil)
)
Desde ya muchas gracias.
juan010101- Mensajes : 8
Fecha de inscripción : 26/03/2016
Edad : 44
Re: Acotar Polilínea
Por favor sube dwg donde quieres aplicarlo con un ejemplo de cómo deben quedar las cotas.
Lo mejor es subirlo en formato ZIP . desde el e-transmit del propio acad .
Lo mejor es subirlo en formato ZIP . desde el e-transmit del propio acad .
Re: Acotar Polilínea
Gracias por responder.
En vez de DWG (si me disculpan), subo tres imágenes que espero explique lo que pasa y que es lo que necesito:
En la imagen se muestra una polilínea que luego de ejecutar el Lisp que modifique hace lo siguiente:
Pero si a la misma polilínea le agrego un arco o semicírculo, el Lisp no hace nada:
Lo que necesito es que el programa, no solo acote linealmente, sino que también lo haga con los segmentos curvos de la polilínea.
En vez de DWG (si me disculpan), subo tres imágenes que espero explique lo que pasa y que es lo que necesito:
En la imagen se muestra una polilínea que luego de ejecutar el Lisp que modifique hace lo siguiente:
Pero si a la misma polilínea le agrego un arco o semicírculo, el Lisp no hace nada:
Lo que necesito es que el programa, no solo acote linealmente, sino que también lo haga con los segmentos curvos de la polilínea.
juan010101- Mensajes : 8
Fecha de inscripción : 26/03/2016
Edad : 44
Re: Acotar Polilínea
Mientras busco algo que acote con cotas tradicionales, aqui dejo esta que lo hace encima de cada segmento.
- Código:
; Devuelve la longitud de todos los tramos de una polilinea (incluso los curvos).
;;;oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
(defun c:cota_pol (/ ang end explst h ini ins len mid n pl sel)
(vl-load-com)
(setvar "dimzin" 0)
(defun processpline (poly)
(setq explst (vlax-invoke poly 'explode))
(foreach x explst
(setq mid (vlax-curve-getpointatdist x (/ (vlax-curve-getdistatparam x (vlax-curve-getendparam x)) 2.0)))
(setq len (vlax-curve-getdistatpoint x (vlax-curve-getendpoint x)))
(setq ini (vlax-curve-getstartpoint x))
(setq end (vlax-curve-getendpoint x))
(setq ang (rem (angle ini end) pi))
(if (> ang (/ pi 2.0))
(setq ang (+ pi ang))
)
(setq ins (polar mid (+ ang (* pi 0.5)) (* 1.5 (getvar "textsize"))))
(entmake (list '(0 . "TEXT")
(cons 1 (rtos len 2 2))
'(7 . "STANDARD")
(cons 10 ins)
(cons 11 ins)
(cons 40 h)
(cons 50 ang)
'(72 . 1)
'(73 . 2)
)
)
(vla-delete x)
)
)
(setq n 0)
(setq h (cdr (assoc 40 (entget (tblobjname "style" (getvar "Textstyle"))))))
(if (= h 0)
(setq h (getvar "textsize"))
)
(princ "\nSelecciona Polilineas: ")
(if (setq sel (ssget "_:S" (list (cons 0 "LWPOLYLINE"))))
(repeat (sslength sel)
(setq pl (ssname sel n))
(processpline (vlax-ename->vla-object pl))
(setq n (1+ n))
)
)
(prin1)
)
;;;oooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo
Dominguez- Mensajes : 148
Fecha de inscripción : 20/03/2016
Edad : 74
Localización : Zaragoza (España)
Re: Acotar Polilínea
Bueno aqui esta lo que pides.
https://www.dropbox.com/sh/rfuxvm2t2ialurd/AACYgVOHfzIqeN5z-eh-dTI9a?dl=0
La rutina se llama Autocota.VLX, espero que te sea util.
Un saludo
https://www.dropbox.com/sh/rfuxvm2t2ialurd/AACYgVOHfzIqeN5z-eh-dTI9a?dl=0
La rutina se llama Autocota.VLX, espero que te sea util.
Un saludo
Dominguez- Mensajes : 148
Fecha de inscripción : 20/03/2016
Edad : 74
Localización : Zaragoza (España)
Re: Acotar Polilínea
Dominguez escribió:Bueno aqui esta lo que pides.
https://www.dropbox.com/sh/rfuxvm2t2ialurd/AACYgVOHfzIqeN5z-eh-dTI9a?dl=0
La rutina se llama Autocota.VLX, espero que te sea util.
Un saludo
Hola, muchas gracias, si bien la rutina hace bastante bien lo que necesito, lo que me hace falta son las líneas de código que haría que la rutina que alteré de la original acote los tramos curvos.
No solo necesito esas líneas de código, sino que yo tenga pleno control del programa, dado que lo optimicé para hacer esa tarea en particular sin necesidad de “setear” parámetros.
Saludos y gracias.
juan010101- Mensajes : 8
Fecha de inscripción : 26/03/2016
Edad : 44
Re: Acotar Polilínea
Siento decirte que esta rutina me la encontre asi, compilada, no se a quien pertenece, asi que no te puedo ayudar con el codigo abierto que pides.juan010101 escribió:Hola, muchas gracias, si bien la rutina hace bastante bien lo que necesito, lo que me hace falta son las líneas de código que haría que la rutina que alteré de la original acote los tramos curvos.
No solo necesito esas líneas de código, sino que yo tenga pleno control del programa, dado que lo optimicé para hacer esa tarea en particular sin necesidad de “setear” parámetros.
Un saludo
Dominguez- Mensajes : 148
Fecha de inscripción : 20/03/2016
Edad : 74
Localización : Zaragoza (España)
Re: Acotar Polilínea
Hola a tod@s
juan010101: Fíjate en el foro CADTutor. En el post 10 tienes la rutina DMP de Fixo, la cual hace lo que querés. Probada en Acad 2007 inglés. Va el link:
http://www.cadtutor.net/forum/showthread.php?69431-Dimension-along-a-curvy-polyline
Saludos
juan010101: Fíjate en el foro CADTutor. En el post 10 tienes la rutina DMP de Fixo, la cual hace lo que querés. Probada en Acad 2007 inglés. Va el link:
http://www.cadtutor.net/forum/showthread.php?69431-Dimension-along-a-curvy-polyline
Saludos
jademar- Mensajes : 25
Fecha de inscripción : 03/04/2016
Re: Acotar Polilínea
jademar escribió:Hola a tod@s
juan010101: Fíjate en el foro CADTutor. En el post 10 tienes la rutina DMP de Fixo, la cual hace lo que querés. Probada en Acad 2007 inglés. Va el link:
http://www.cadtutor.net/forum/showthread.php?69431-Dimension-along-a-curvy-polyline
Saludos
Excelente, Muchísimas Gracias por la ayuda.
Ya lo modifiqué para que haga exactamente lo que necesito.
Saludos.
juan010101- Mensajes : 8
Fecha de inscripción : 26/03/2016
Edad : 44
Temas similares
» Acotar Angulos
» Polilinea 3D a Polilinea
» Longitud de Polilinea
» Dibujar polilinea 3d en 3dfaces
» INVERTIR VÉRTICES DE POLILINEA
» Polilinea 3D a Polilinea
» Longitud de Polilinea
» Dibujar polilinea 3d en 3dfaces
» INVERTIR VÉRTICES DE POLILINEA
Página 1 de 1.
Permisos de este foro:
No puedes responder a temas en este foro.
|
|