MP
I should have said "not supported with A2000 and A2004." because it works fine with A2007, I use it a lot !
(vlax-property-available-p lwPolyLineObject 'coordinates t) returns T, as I understood Joe said the error got by Alan is due to adding or removing too much vertex at the same time.
Anyway, here's a new version using entmod rather than (vlax-put pl 'coordinates ...), perhaps it works on 'old' versions ?
EDIT: revised code, 2 commands (see downer reply 31)
;; CPL Calling Function
(defun c:cpl (/ ss n)
(vl-load-com)
(princ
"\nSelect plines or <All>: "
)
(or (setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
)
(if ss
(progn
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq n -1)
(while (setq pl (ssname ss (setq n (1+ n))))
(CleanPline pl nil)
)
(princ (strcat "\n\t" (itoa n) " treated pline(s)."))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(princ "\nNone pline selected.")
)
(princ)
)
;; PPL Calling Function
(defun c:ppl (/ ss n)
(vl-load-com)
(princ
"\nSelect plines or <All>: "
)
(or (setq ss (ssget '((0 . "LWPOLYLINE"))))
(setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
)
(if ss
(progn
(vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq n -1)
(while (setq pl (ssname ss (setq n (1+ n))))
(CleanPline pl T)
)
(princ (strcat "\n\t" (itoa n) " treated pline(s)."))
(vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(princ "\nNone pline selected.")
)
(princ)
)
;; CleanPline (gile) 2007/11/13
;; Deletes superfluous vertex (aligned or overlapped) in a lwpolyline
;; Keeps arcs and widthes.
;;
;; Arguments
;; pl : the polyline to be treated (ename)
;; tt : T ou nil
;; - T deletes all vertex aligned or on the same arc
;; - nil keeps vertex which come back on the pline traject
(defun CleanPline (pl tt / regular-width elst
closed old-p old-b old-sw old-ew new-p
new-b new-sw new-ew b1 b2
)
(defun regular-width (p1 p2 p3 ws1 we1 ws2 we2 / delta norm)
(setq delta (- we2 ws1)
)
(and (= we1 ws2)
(equal (/ (- (vlax-curve-getDistAtPoint pl (trans p2 pl 0))
(vlax-curve-getDistAtPoint pl (trans p1 pl 0))
)
(- (vlax-curve-getDistAtPoint pl (trans p3 pl 0))
(vlax-curve-getDistAtPoint pl (trans p1 pl 0))
)
)
(/ (- we1 (- we2 delta)) delta)
0.01
)
)
)
(setq elst (entget pl))
(and (= 1 (logand 1 (cdr (assoc 70 elst)))) (setq closed T))
(setq old-p (vl-remove-if-not
(function (lambda (x) (= (car x) 10)))
elst
)
old-sw (vl-remove-if-not
(function (lambda (x) (= (car x) 40)))
elst
)
old-ew (vl-remove-if-not
(function (lambda (x) (= (car x) 41)))
elst
)
old-b (vl-remove-if-not
(function (lambda (x) (= (car x) 42)))
elst
)
elst (vl-remove-if
(function (lambda (x) (member (car x) '(10 40 41 42))))
elst
)
)
(and closed (setq old-p (append old-p (list (car old-p)))))
(while (cddr old-p)
(if (or (= (cdar old-sw)
(cdar old-ew)
(cdadr old-sw)
(cdadr old-ew)
)
(regular-width
(cdar old-p)
(cdadr old-p)
(cdaddr old-p)
(cdar old-sw)
(cdar old-ew)
(cdadr old-sw)
(cdadr old-ew)
)
)
(if (and (zerop (cdar old-b))
(zerop (cdadr old-b))
)
(if
(if tt
(null (inters (cdar old-p)
(cdaddr old-p)
(cdar old-p)
(cdadr old-p)
)
)
(betweenp (cdar old-p) (cdaddr old-p) (cdadr old-p))
)
(setq old-p (cons (car old-p) (cddr old-p))
old-b (cons (car old-b) (cddr old-b))
old-sw (cons (car old-sw) (cddr old-sw))
old-ew (cons (cadr old-ew) (cddr old-ew))
)
(setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-sw (cons (car old-sw) new-sw)
new-ew (cons (car old-ew) new-ew)
old-p (cdr old-p)
old-b (cdr old-b)
old-sw (cdr old-sw)
old-ew (cdr old-ew)
)
)
(if
(and
(/= 0.0 (cdar old-b))
(/= 0.0 (cdadr old-b))
(equal (caddr
(setq
b1 (BulgeData (cdar old-b) (cdar old-p) (cdadr old-p))
)
)
(caddr
(setq b2
(BulgeData (cdadr old-b) (cdadr old-p) (cdaddr old-p))
)
)
1e-4
)
(or tt
(or (and (< 0 (car b1)) (< 0 (car b2)))
(and (< (car b1) 0) (< (car b2) 0))
)
)
)
(setq old-p (cons (car old-p) (cddr old-p))
old-b (cons (cons 42 (tan (/ (+ (car b1) (car b2)) 4.0)))
(cddr old-b)
)
old-sw (cons (car old-sw) (cddr old-sw))
old-ew (cons (cadr old-ew) (cddr old-ew))
)
(setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-sw (cons (car old-sw) new-sw)
new-ew (cons (car old-ew) new-ew)
old-p (cdr old-p)
old-b (cdr old-b)
old-sw (cdr old-sw)
old-ew (cdr old-ew)
)
)
)
(setq new-p (cons (car old-p) new-p)
new-b (cons (car old-b) new-b)
new-sw (cons (car old-sw) new-sw)
new-ew (cons (car old-ew) new-ew)
old-p (cdr old-p)
old-b (cdr old-b)
old-sw (cdr old-sw)
old-ew (cdr old-ew)
)
)
)
(if closed
(setq new-p (reverse (append (cdr (reverse old-p)) new-p)))
(setq new-p (append (reverse new-p) old-p))
)
(setq new-b (append (reverse new-b) old-b)
new-sw (append (reverse new-sw) old-sw)
new-ew (append (reverse new-ew) old-ew)
)
(entmod
(append elst
(apply 'append
(apply 'mapcar
(cons 'list (list new-p new-sw new-ew new-b))
)
)
)
)
)
;;; VEC1 Returns the single unit vector from p1 to p2
(defun vec1 (p1 p2 / d)
(if (not (zerop (setq d (distance p1 p2))))
(mapcar '(lambda (x1 x2) (/ (- x2 x1) d)) p1 p2)
)
)
;; BETWEENP Evaluates if pt is between p1 et p2
(defun betweenp (p1 p2 pt)
(or (equal p1 pt 1e-9)
(equal p2 pt 1e-9)
(equal (vec1 p1 pt) (vec1 pt p2) 1e-9)
)
)
;;; TRUNC Returns the list from the first item to the first occurrence
;;; of expression de l'expression (complementary to MEMBER list)
(defun trunc (expr lst)
(if (and lst
(not (equal (car lst) expr))
)
(cons (car lst) (trunc expr (cdr lst)))
)
)
;; BulgeData Returns a 'bulge datas list' (angle radius center)
(defun BulgeData (bu p1 p2 / ang rad)
(setq ang (* 2 (atan bu))
rad (/ (distance p1 p2)
(* 2 (sin ang))
)
cen (polar p1
(+ (angle p1 p2) (- (/ pi 2) ang))
rad
)
)
(list (* ang 2.0) rad cen)
)
;; TAN Returns the angle tangent
(defun tan (ang)
(/ (sin ang) (cos ang))
)