Mais polilinhas

Bom, pra apagar já postei, agora pra INCLUIR vértices, a idéia é: clica o segmento e escolhe a posição do novo vértice… mais…

(defun c:avert  (/ tmp ent pts pts2 pt dist lst pr tp b sw ew n)
(
tbn:error-init '(("cmdecho" 0) t))
(
while (progn
(if (> (length lst) 0)
(
initget "U" 0))
(
setq tmp
(entsel
(strcat "nSelecione o segmento a adicionar o vertice"
(if (> (length lst) 0) " [Undo]" ""))))
(
or tmp (/= 52 (getvar "errno"))))
(
if (= "U" tmp)
(
progn
(setq tmp (car lst)
lst (cdr lst))
(
entmod tmp)
(
entupd (dxf -1 tmp)))
(
if tmp
(if (wcmatch (dxf 0 (car tmp)) "*POLYLINE")
(
progn
(setq ent (car tmp)
vla (vlax-ename->vla-object ent)
pts (get-points-polig ent)
pr (vlax-curve-getclosestpointtoprojection
ent (trans (cadr tmp) 1 0) '(0 0 1))
dist (vlax-curve-getdistatpoint ent pr)
pts2 nil
n 0
b nil)
(
sssetfirst nil (ssadd ent (ssadd)))
(
while (if pts
(setq tmp (vlax-curve-getdistatpoint ent (car pts))
tmp (< (if (and (zerop tmp)
(
= 1 (length pts)))
(
get-length-of ent)
tmp)
dist)))
(
setq pts2 (append pts2 (list (car pts)))
pts (cdr pts))
(
if (= "LWPOLYLINE" (dxf 0 ent))
(
progn
(vla-GetWidth vla n 'sw 'ew)
(
setq b (append b (list (list (vla-getbulge vla n)
sw ew)))
n (1+ n)))))
(
if (setq pr (getpoint "nOnde colocar o vertice" pr))
(
progn
(setq pr (trans pt 1 0)
pts2 (append pts2 (list pr) pts)
lst (cons (entget ent) lst)
pts2 (if (= "LWPOLYLINE" (dxf 0 ent))
(
mapcar '(lambda (x) (remove-n 2 x)) pts2)
pts2)
pts2 (apply 'append pts2)
b (append b '((0.0 0.0 0.0))))
(
if (= "LWPOLYLINE" (dxf 0 ent))
(
repeat (length pts)
(
vla-GetWidth vla n 'sw 'ew)
(
setq b (append b
(list (list (vla-getbulge vla n) sw ew)))
n (1+ n))))
(
vla-put-coordinates vla
(vlax-safearray-fill
(vlax-make-safearray
vlax-vbdouble

(cons 0 (1- (length pts2))))
pts2))
(
setq n 0)
(
if (= "LWPOLYLINE" (dxf 0 ent))
(
foreach x b
(vla-setbulge vla n (car x))
(
vla-setwidth vla n (cadr x) (caddr x))
(
setq n (1+ n)))))))))))
(
sssetfirst nil nil)
(
tbn:error-restore))

Link(s) da(s) subrotina(s) usada(s):
tbn:error-init, dxf, get-points-polig, get-length-of, remove-n, tbn:error-restore

me pergunte por que tem de clicar nesse link…

2 comentários em “Mais polilinhas”

Deixe um comentário

Carrinho de compras
Rolar para cima