Eliminar vértices
3 participantes
Página 1 de 1.
Eliminar vértices
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:
Espero haber sido claro, agradezco cualquier ayuda o sugerencia.
Saludos y gracias....
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)))
)
Espero haber sido claro, agradezco cualquier ayuda o sugerencia.
Saludos y gracias....
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Eliminar vértices
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 : 91
Fecha de inscripción : 12/08/2016
Re: Eliminar vértices
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é....
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 : 195
Fecha de inscripción : 17/03/2016
Re: Eliminar vértices
Usalo de esta manera
Pero esto lo hara sobre el ultimo objeto dibujado.
- Código:
(setq SelectionSet (ssget "L"))
Pero esto lo hara sobre el ultimo objeto dibujado.
Marco Jacinto- Mensajes : 91
Fecha de inscripción : 12/08/2016
Re: Eliminar vértices
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.")
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- Mensajes : 98
Fecha de inscripción : 22/03/2016
Edad : 56
Localización : Bogota DC-Colombia
Re: Eliminar vértices
Buen día.
Bernardo, parece ser que es justo lo que necesito. Te agradezco.
Saludos
Bernardo, parece ser que es justo lo que necesito. Te agradezco.
Saludos
eliasp- Mensajes : 195
Fecha de inscripción : 17/03/2016
Re: Eliminar vértices
Pues hombre Eliasp me agrada colaborar y espero te sea útil.
Saludos y que te rinda
Bernardo C
Saludos y que te rinda
Bernardo C
bernie67- Mensajes : 98
Fecha de inscripción : 22/03/2016
Edad : 56
Localización : Bogota DC-Colombia
Temas similares
» INVERTIR VÉRTICES DE POLILINEA
» Eliminar espacios "de más" en textos....
» Eliminar mensaje de error
» Eliminar líneas repetidas de una lista
» Eliminar espacios "de más" en textos....
» Eliminar mensaje de error
» Eliminar líneas repetidas de una lista
Página 1 de 1.
Permisos de este foro:
No puedes responder a temas en este foro.
|
|