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...