Add ucs case , and deal Line or 2point-Polyline aligned X-Axis or Y-Axis case .
(defun c:test (/ *error* interpts en0 p0 d0 minpt
maxpt con ss e pts l l1 res a
b p _pb _err
)
;; Trim every other
;; by GSLS(SS) 2012-07-28
;; just for test in WCS
(defun interpts (e1 e2 lim / m)
(if (not
(minusp
(vlax-safearray-get-u-bound
(vlax-variant-value
(setq m (vla-IntersectWith
(vlax-ename->vla-object e1)
(vlax-ename->vla-object e2)
lim
)
)
)
1
)
)
)
((lambda (a / b r)
(repeat (/ (length a) 3)
(setq b (list (car a) (cadr a) (caddr a))
a (cdddr a)
r (cons b r)
)
)
)
(vlax-safearray->list (vlax-variant-value m))
)
)
)
(if
(and (setq
en0 (entsel "\nSelect every other trim curve's point :")
)
(setq p0 (cadr en0))
(setq en0 (car en0))
(setq p0 (vlax-curve-getclosestpointto en0 p0))
(setq d0 (vlax-curve-getDistAtPoint en0 p0))
(not
(vla-GetBoundingBox
(vlax-ename->vla-object en0)
(quote minpt)
(quote maxpt)
)
)
(setq minPt (vlax-safearray->list minPt))
(setq maxPt (vlax-safearray->list maxPt))
(if (or (equal (car minpt) (car maxpt) 1e-6)
(equal (cadr minpt) (cadr maxpt) 1e-6)
);_deal line alinged X-Axis or Y-Axis CASE
(setq ss (ssget "_F"
(list (trans minpt 0 1) (trans maxpt 0 1))
(list (cons 0 "*LINE,CIRCLE,ARC,ELLIPSE"))
)
)
(progn
(setq con
(list minpt
(list (car maxPt) (cadr minPt) 0.0)
maxPt
(list (car minpt) (cadr maxpt) 0.0)
)
)
;; add ucs case
(if (= (getvar "WORLDUCS") 0)
(setq con (mapcar (function (lambda (x)
(trans x 0 1)
)
)
con
)
)
) ;_UCS CASE
(setq
ss (ssget "CP"
con
(list (cons 0 "*LINE,CIRCLE,ARC,ELLIPSE"))
)
)
)
)
(setq ss (ssdel en0 ss))
(> (sslength ss) 1)
)
(progn
(princ "\nEnter next Step ...")
(setq i -1)
(while (setq e (ssname ss (setq i (1+ i))))
(if (setq pts (interpts en0 e 0))
(foreach a pts
(setq l (cons (list e (vlax-curve-getDistAtPoint en0 a)) l))
)
)
)
(setq l (vl-sort l
(function (lambda (e1 e2)
(< (cadr e1) (cadr e2))
)
)
)
)
(while (and (setq a (car l)) (< (cadr a) d0))
(setq l1 (cons a l1)
l (cdr l)
)
)
(setq res (list (list (caar l1)
(caar l)
(vlax-curve-getPointAtDist
en0
(* 0.5 (+ (cadar l1) (cadar l)))
)
)
)
l1 (cdr l1)
l (cdr l)
)
(while (cadr l1)
(setq a (car l1)
b (cadr l1)
l1 (cddr l1)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(while (cadr l)
(setq a (car l)
b (cadr l)
l (cddr l)
)
(setq res (cons (list (car a)
(car b)
(vlax-curve-getpointatdist
en0
(* 0.5 (+ (cadr a) (cadr b)))
)
)
res
)
)
)
(if (vlax-curve-isClosed en0)
;;add en0 is closed dealing .
(if (and l1 l)
(setq res
(cons
(list
(caar l1)
(caar l)
(vlax-curve-getclosestpointto
en0
(mapcar
(function (lambda (x)
(* x 0.5)
)
)
(mapcar (function +)
(vlax-curve-getpointatdist en0 (cadar l1))
(vlax-curve-getpointatdist en0 (cadar l))
)
)
)
)
res
)
)
)
(progn
(if l1
(setq res (cons (list (caar l1)
nil
(vlax-curve-getpointatdist
en0
(* 0.5 (cadar l1))
)
)
res
)
)
)
(if l
(setq
res (cons (list (caar l)
nil
(vlax-curve-getpointatdist
en0
(* 0.5
(+ (cadar l)
(vlax-curve-getDistAtPoint
en0
(vlax-curve-getendpoint en0)
)
)
)
)
)
res
)
)
)
)
)
;;....
(if res
(progn
(setq _err *error*
_pb (getvar "pickbox")
)
(defun *error* (msg)
(command)
(command)
(if (or (= msg "Function cancelled")
(= msg "quit / exit abort")
)
(princ msg)
(princ (strcat "\nerror " msg))
)
(command "_.undo" "end")
(setvar "pickbox" _pb)
(setq *error* _err)
(princ)
)
(setvar "pickbox" 2)
(command "_.undo" "begin")
(foreach l res
(if (apply 'and l)
(command "_.trim"
(car l)
(cadr l)
""
(trans (caddr l) 0 1);_add usc case
""
)
(if (and (car l) (caddr l))
(command "_.trim" (car l) "" (trans (caddr l) 0 1) "")
)
)
)
(command "_.undo" "end")
(setvar "pickbox" _pb)
(setq *error* _err)
)
)
)
)
(princ "\n...End routine .")
(princ)
)
