Acotar Polilínea

Ir abajo

Acotar Polilínea

Mensaje por juan010101 el Dom Abr 22, 2018 4:15 pm

Saludos al Grupo,

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 : 4
Fecha de inscripción : 26/03/2016
Edad : 38

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por Admin el Miér Abr 25, 2018 4:59 pm

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 .

Admin
Admin

Mensajes : 177
Fecha de inscripción : 16/03/2016
Edad : 69
Localización : CORDOBA ARGENTINA

Ver perfil de usuario http://acadhispano.foroargentina.net

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por juan010101 el Miér Abr 25, 2018 10:01 pm

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.


juan010101

Mensajes : 4
Fecha de inscripción : 26/03/2016
Edad : 38

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por Dominguez el Jue Abr 26, 2018 7:00 pm

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
avatar
Dominguez

Mensajes : 73
Fecha de inscripción : 20/03/2016
Edad : 68
Localización : Zaragoza (España)

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por Dominguez el Jue Abr 26, 2018 7:08 pm

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
avatar
Dominguez

Mensajes : 73
Fecha de inscripción : 20/03/2016
Edad : 68
Localización : Zaragoza (España)

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por juan010101 el Jue Abr 26, 2018 9:59 pm

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 : 4
Fecha de inscripción : 26/03/2016
Edad : 38

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por Dominguez el Sáb Abr 28, 2018 12:20 pm

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.
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.
Un saludo
avatar
Dominguez

Mensajes : 73
Fecha de inscripción : 20/03/2016
Edad : 68
Localización : Zaragoza (España)

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por jademar el Sáb Abr 28, 2018 4:27 pm

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

jademar

Mensajes : 14
Fecha de inscripción : 03/04/2016

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por juan010101 el Sáb Abr 28, 2018 5:10 pm

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 : 4
Fecha de inscripción : 26/03/2016
Edad : 38

Ver perfil de usuario

Volver arriba Ir abajo

Re: Acotar Polilínea

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Volver arriba

- Temas similares

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