acad hispano
¿Quieres reaccionar a este mensaje? Regístrate en el foro con unos pocos clics o inicia sesión para continuar.

Eliminar vértices

Ir abajo

Eliminar vértices Empty Eliminar vértices

Mensaje por eliasp el Sáb Dic 28, 2019 3:45 am

Buen día señores, luego de varios meses de ausencia, vuelvo a las andadas.

En esta ocasión, estoy trabajando en proyectos de calles. Tengo resuelta la mitad del trabajo, explico:

En el archivo anexo, tracé un par de polilineas (en color amarillo) entre las cuales debo obtener un eje central (en color blanco). Ésto lo logré con ésta rutina:
Código:

(vl-load-com)
(defun inicio()
  (tblobjname "STYLE" "nombredeestilo")
  (command "_-style" "nombredeestilo" "verdana" "0" "1" "0" "_no" "_no")
  (command "_-layer" "make" "Rayas" "_color" "7" "Rayas" "")
  ;(command "_-layer" "make" "Bombeos" "_color" "7" "Bombeos" "")
  (command "_-layer" "make" "Borrar" "_color" "2" "Borrar" "")
  (setvar "osmode" 1)
  (setq acadobj(vlax-get-acad-object))
  (setq acaddoc(vla-get-activedocument acadobj))
  (setq acadesp(vla-get-modelspace acaddoc))
  (SETQ appa  (VLA-GET-APPLICATION acaddoc))
  (setq styles-collection ( vla-get-textstyles acaddoc))
  (setvar "modemacro" "Ing. José Elías Pelayo")
;---CONSTANTES
  (setq dista 25)
  (setq lista nil)
  )
(defun safefill(ptlist)(vlax-safearray-fill(vlax-make-safearray vlax-vbdouble(cons 0 (1-(length(apply 'append ptlist)))))(apply 'append ptlist)))
(defun mitad(obj)(setq pmedio(vlax-curve-getpointatdist obj(/(vlax-curve-getdistatparam obj(vlax-curve-getendparam obj))2.0))))
(defun midpt (a b) (mapcar '/ (mapcar '+ a b) '(2. 2. 2.)))
(defun izq()
  ;(vla-put-color ejeizq acred)
  (setq long longizq)
  (setq olin ejeizq)
  (setq otra ejeder)
  )
(defun der()
  ;(vla-put-color ejeder accyan)
  (setq long longder)
  (setq olin ejeder)
  (setq otra ejeizq)
  )
(defun c:ejecentral()
  (inicio)
  (setq ejeizq(vlax-ename->vla-object(car(entsel "Eje Izquierdo..."))))
  (setq ejeder(vlax-ename->vla-object(car(entsel "Eje Derechoo..."))))
  (setq longizq(vlax-get-property ejeizq 'length)
 longder(vlax-get-property ejeder 'length)
 )
  (if(< longizq longder)
    (izq)
    (der)
    )
  (while (<= dista long)
    (setq punto0(vlax-curve-getpointatdist olin dista))
    (setq punto1(vlax-curve-getClosestPointTo otra punto0 ))
    ;(vla-addcircle acadesp (vlax-3d-point punto0) 5)
    ;(vla-addcircle acadesp (vlax-3d-point punto1) 5)
    ;(setq linea(vla-addline acadesp (vlax-3d-point punto0)(vlax-3d-point punto1)))
    ;(mitad linea)
    (setq z(midpt punto0 punto1))
    ;(vla-addcircle acadesp (vlax-3d-point z) 2)
    (setq lista(cons z lista))

    
    (setq dista(+ dista 5))
    )
  (setq lista(reverse lista))
  (setvar "clayer" "Rayas")
  (setq eje(vla-addpolyline acadesp(safefill lista)))
  )
Lo que me falta, que es en lo que necesito ayuda es en eliminar los vértices de los tramos rectos, que éstos estén definidos sólo por el primero y el último, antes de un cambio de dirección. Para que de ésta forma, queden el menor número de vértices posible.

Espero haber sido claro, agradezco cualquier ayuda o sugerencia.

Saludos y gracias....

eliasp

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

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por Marco Jacinto el Mar Ene 07, 2020 12:52 am

puedes usar la función acet-overkill2 desde tu programa
Código:

(setq SelectionSet (ssget "X"))

Then run overkill.

(load "overkillsup")

(acet-overkill2 (list SelectionSet 0.000001 nil T nil nil))

Marco Jacinto

Mensajes : 74
Fecha de inscripción : 12/08/2016

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por eliasp el Mar Ene 07, 2020 5:57 am

Ok. Gracias Marco.

Sin embargo, la verdad es que no supe como usarla.... a ver, una vez que tracé mi polilínea central aplico el selectionset pasandole la lista de puntos como argumento o la poli....????

Le intenté de las dos formas y no pasó nada.... perdón, estoy más oxidado de lo que pensé....

eliasp

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

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por Marco Jacinto el Miér Ene 08, 2020 12:50 am

Usalo de esta manera

Código:
(setq SelectionSet (ssget "L"))

Pero esto lo hara sobre el ultimo objeto dibujado.

Marco Jacinto

Mensajes : 74
Fecha de inscripción : 12/08/2016

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por bernie67 el Vie Ene 10, 2020 10:25 pm

Me encontré este lisp, no se si te sirva, ya me contaras. agradeciendo a Eduardo Muñoz que lo elaboro
un saludo
Bernardo Corradine


;;;===========================================================================
;;;
;;; Alisa.lsp
;;;
;;; Eduardo Muñoz
;;; Time-stamp: "Tuesday, 20 July 2004 - 17:34:57"
;;;
;;;===========================================================================
;;;
;;; Elimina vertices innecesarios de una polilinea
;;;
;;;===========================================================================


;; Angulo de desvío mínimo a considerar (en grados). Si el desvío entre tres
;; puntos consecutivos es menor que *min-ang* se elimina el intermedio.
(setq *min-ang* 4)


(defun c:ALISA ( / ssplines pline info lpt)
(setvar "cmdecho" 0)
(if (setq ssplines (ssget '((0 . "LWPOLYLINE"))))
(progn
(command "._undo" "_begin")
(while (setq pline (ssname ssplines 0))
(setq info (entget pline)
lpt (apply 'append
(mapcar '(lambda (x) (if (= (car x) 10)
(list (cdr x))))
info))
lpt (lpoints-smooth lpt))
(lwpline-make lpt (cdr (assoc 8 info))
(cdr (assoc 62 info)) (cdr (assoc 70 info)))
(ssdel pline ssplines)
(entdel pline)
(command "._undo" "_end"))))
(princ))


(defun lwpline-make (lpt cap color closed / pline)
(setq pline (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(67 . 0)
(cons 8 cap)
(cons 62 (if color color 256))
'(100 . "AcDbPolyline")
(cons 90 (length lpt))
(cons 70 closed)
'(43 . 0.0)
'(38 . 0.0)
'(39 . 0.0)))
(foreach pt lpt
(setq pline (append pline
(list (cons 10 pt)
'(40 . 0.0)
'(41 . 0.0)
'(42 . 0.0)))))
(setq pline (append pline '((210 0.0 0.0 1.0))))
(entmake pline))



(defun lpoints-smooth (lpt / end min-ang p1 new-lpt)
(setq end (last lpt)
min-ang (* (/ (float *min-ang*) 180) pi))
(while (cddr lpt)
(setq p1 (car lpt)
lpt (cdr lpt))
(while (and (cdr lpt)
(< (abs (- (angle p1 (car lpt))
(angle (car lpt) (cadr lpt))))
min-ang))
(setq lpt (cdr lpt)))
(setq new-lpt (cons p1 new-lpt)))
;; añadimos lo que queda
(append (reverse new-lpt) (if lpt lpt (list end))))


(princ "\nNuevo comand \"ALISA\" cargado.")

bernie67
bernie67

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

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por eliasp el Lun Ene 13, 2020 2:52 pm

Buen día.
Bernardo, parece ser que es justo lo que necesito. Te agradezco.

Saludos

eliasp

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

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por bernie67 el Mar Ene 14, 2020 12:33 am

Pues hombre Eliasp me agrada colaborar y espero te sea útil.
Saludos y que te rinda
Bernardo C
bernie67
bernie67

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

Volver arriba Ir abajo

Eliminar vértices Empty Re: Eliminar vértices

Mensaje por Contenido patrocinado


Contenido patrocinado


Volver arriba Ir abajo

Volver arriba


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