(setq e (car (entsel))) => picked curve - spline
(setq p (getpoint)) => picked point
Command: (vlax-curve-getfurthestpointto e p)
Hard error occurred ***
internal stack limit reached (simulated)
Not necessarily...
Function name isn't so important I thought TO - like closest point to...
My function uses vl-sort function witch should remove duplicates when reaching solution point, so (length ptlstsort) shouldn't be always 4 - that was the main point of my code... But now I see that recursion isn't so good approach as there are cases when length should be 4 and already met opportunities for solution : line with mid or circle, ellipse with center...
The vla-, vlax- naming prefix is recognised as the naming convention used by Visual Lisp library functions.
Zoltan, I agree, but this is an exeption - intension was to make real programmers to revide VisualLisp functions as this one was missed
Thank you Lee very much... Only skipped "RAY", so my final function with acceptable tolerance for almost if not exact result is 1e-8...Code - Auto/Visual Lisp: [Select]
(+ SP (* (- EP SP) (/ 1.0 3.0)) ) (+ SP (* (- EP SP) (/ 2.0 3.0)) ) EP ) ) ) ) ) ) ) (FurthestParameter (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth (Car dist) params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr dist) params)) 1e-8)) ) ) (If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth (Car dist) params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr dist) params)) 1e-8)) ) ) TOL ) ) ) (VLAX-Curve-GetPointAtParam CURVE (FurthestParameter (VLAX-Curve-GetStartParam CURVE) (VLAX-Curve-GetEndParam CURVE) TOL) ) ) (cond nil ) nil ) ( (= "LINE" etype) ) ) ) (= "LWPOLYLINE" etype) ) (car ) ) ) ) ( t ) ) )
P.S. You must use (vl-load-com) before lake every other vlax-curve-function...
M.R. :-)
@ribarm:
Nice code! One slight issue - when you call all the "vlax-curve" functions you need to supply your "CURVE" argument as a VLA-Object, rather than an entity name
I corrected your call to "ZF-GetFurthestPointFrom" in the quote above to use (vlax-ename->vla-object ent).
All best, sincerely M.R. (arch. not programmer) (I know that I've tried, and maybe my effort won't be pointless)
If you didn't noticed vlax-curve-functions don't need VLA-OBJECT as argument - it is totally acceptable for argument to be ENAME... And no it's not nice code at all, it only works for circle and point that is not center and gives approx. correct result, but in all other cases of curves and I mean real curves not line, pline, xline... it will probably fail... This topic is only ilustrative - to point out that there is important missing vlax-curve function in VLisp... And who will provide solution, real one with exact return value like vlax-curve-getclosestpointto, I don't know, suppose the one that made vlax-curve-getclosestpointto (I would change sign of evaluating distances from < to > and I mean that this is probably the case... Only thing is how to make that someone that knows to do that to really do that...
All best, sincerely M.R. (arch. not programmer) (I know that I've tried, and maybe my effort won't be pointless)
Thank you Lee very much... Only skipped "RAY", so my final function with acceptable tolerance for almost if not exact result is 1e-8...
Zoltan, it doesn't matter between witch points routine performs recursion, as there are cases where this method isn't good...
Look in picture I uploaded and you'll see that this method is useless... Only way to find correct result is to check every point or param. on curve.
Zoltan, it doesn't matter between witch points routine performs recursion, as there are cases where this method isn't good...
Look in picture I uploaded and you'll see that this method is useless... Only way to find correct result is to check every point or param. on curve.
I see. This problem just got more interesting.
It is not possible to test every parameter on the curve, because there is an infinite number of them (well, as many as there are real numbers in Lisp). The divide-and-concur method should still work if we dividing the cure into many more points than just 4. We will have to think of a logic to determine the number of points to give the best trade-off between speed and accuracy.
(Defun ZF-GetFurthestPointFrom (CURVE POINT TOL / FurthestParameter )
(Defun FurthestParameter (SP EP TOL / params dist )
(SetQ params (List SP
(+ SP (* (- EP SP) (/ 1.0 100.0)) )
(+ SP (* (- EP SP) (/ 2.0 100.0)) )
(+ SP (* (- EP SP) (/ 3.0 100.0)) )
(+ SP (* (- EP SP) (/ 4.0 100.0)) )
(+ SP (* (- EP SP) (/ 5.0 100.0)) )
(+ SP (* (- EP SP) (/ 6.0 100.0)) )
(+ SP (* (- EP SP) (/ 7.0 100.0)) )
(+ SP (* (- EP SP) (/ 8.0 100.0)) )
(+ SP (* (- EP SP) (/ 9.0 100.0)) )
(+ SP (* (- EP SP) (/ 10.0 100.0)) )
(+ SP (* (- EP SP) (/ 11.0 100.0)) )
(+ SP (* (- EP SP) (/ 12.0 100.0)) )
(+ SP (* (- EP SP) (/ 13.0 100.0)) )
(+ SP (* (- EP SP) (/ 14.0 100.0)) )
(+ SP (* (- EP SP) (/ 15.0 100.0)) )
(+ SP (* (- EP SP) (/ 16.0 100.0)) )
(+ SP (* (- EP SP) (/ 17.0 100.0)) )
(+ SP (* (- EP SP) (/ 18.0 100.0)) )
(+ SP (* (- EP SP) (/ 19.0 100.0)) )
(+ SP (* (- EP SP) (/ 20.0 100.0)) )
(+ SP (* (- EP SP) (/ 21.0 100.0)) )
(+ SP (* (- EP SP) (/ 22.0 100.0)) )
(+ SP (* (- EP SP) (/ 23.0 100.0)) )
(+ SP (* (- EP SP) (/ 24.0 100.0)) )
(+ SP (* (- EP SP) (/ 25.0 100.0)) )
(+ SP (* (- EP SP) (/ 27.0 100.0)) )
(+ SP (* (- EP SP) (/ 28.0 100.0)) )
(+ SP (* (- EP SP) (/ 29.0 100.0)) )
(+ SP (* (- EP SP) (/ 30.0 100.0)) )
(+ SP (* (- EP SP) (/ 31.0 100.0)) )
(+ SP (* (- EP SP) (/ 32.0 100.0)) )
(+ SP (* (- EP SP) (/ 33.0 100.0)) )
(+ SP (* (- EP SP) (/ 34.0 100.0)) )
(+ SP (* (- EP SP) (/ 35.0 100.0)) )
(+ SP (* (- EP SP) (/ 36.0 100.0)) )
(+ SP (* (- EP SP) (/ 37.0 100.0)) )
(+ SP (* (- EP SP) (/ 38.0 100.0)) )
(+ SP (* (- EP SP) (/ 39.0 100.0)) )
(+ SP (* (- EP SP) (/ 40.0 100.0)) )
(+ SP (* (- EP SP) (/ 41.0 100.0)) )
(+ SP (* (- EP SP) (/ 42.0 100.0)) )
(+ SP (* (- EP SP) (/ 43.0 100.0)) )
(+ SP (* (- EP SP) (/ 44.0 100.0)) )
(+ SP (* (- EP SP) (/ 45.0 100.0)) )
(+ SP (* (- EP SP) (/ 46.0 100.0)) )
(+ SP (* (- EP SP) (/ 47.0 100.0)) )
(+ SP (* (- EP SP) (/ 48.0 100.0)) )
(+ SP (* (- EP SP) (/ 49.0 100.0)) )
(+ SP (* (- EP SP) (/ 50.0 100.0)) )
(+ SP (* (- EP SP) (/ 51.0 100.0)) )
(+ SP (* (- EP SP) (/ 52.0 100.0)) )
(+ SP (* (- EP SP) (/ 53.0 100.0)) )
(+ SP (* (- EP SP) (/ 54.0 100.0)) )
(+ SP (* (- EP SP) (/ 55.0 100.0)) )
(+ SP (* (- EP SP) (/ 56.0 100.0)) )
(+ SP (* (- EP SP) (/ 57.0 100.0)) )
(+ SP (* (- EP SP) (/ 58.0 100.0)) )
(+ SP (* (- EP SP) (/ 59.0 100.0)) )
(+ SP (* (- EP SP) (/ 60.0 100.0)) )
(+ SP (* (- EP SP) (/ 61.0 100.0)) )
(+ SP (* (- EP SP) (/ 62.0 100.0)) )
(+ SP (* (- EP SP) (/ 63.0 100.0)) )
(+ SP (* (- EP SP) (/ 64.0 100.0)) )
(+ SP (* (- EP SP) (/ 65.0 100.0)) )
(+ SP (* (- EP SP) (/ 66.0 100.0)) )
(+ SP (* (- EP SP) (/ 67.0 100.0)) )
(+ SP (* (- EP SP) (/ 68.0 100.0)) )
(+ SP (* (- EP SP) (/ 69.0 100.0)) )
(+ SP (* (- EP SP) (/ 70.0 100.0)) )
(+ SP (* (- EP SP) (/ 71.0 100.0)) )
(+ SP (* (- EP SP) (/ 72.0 100.0)) )
(+ SP (* (- EP SP) (/ 73.0 100.0)) )
(+ SP (* (- EP SP) (/ 74.0 100.0)) )
(+ SP (* (- EP SP) (/ 75.0 100.0)) )
(+ SP (* (- EP SP) (/ 76.0 100.0)) )
(+ SP (* (- EP SP) (/ 77.0 100.0)) )
(+ SP (* (- EP SP) (/ 78.0 100.0)) )
(+ SP (* (- EP SP) (/ 79.0 100.0)) )
(+ SP (* (- EP SP) (/ 80.0 100.0)) )
(+ SP (* (- EP SP) (/ 81.0 100.0)) )
(+ SP (* (- EP SP) (/ 82.0 100.0)) )
(+ SP (* (- EP SP) (/ 83.0 100.0)) )
(+ SP (* (- EP SP) (/ 84.0 100.0)) )
(+ SP (* (- EP SP) (/ 85.0 100.0)) )
(+ SP (* (- EP SP) (/ 86.0 100.0)) )
(+ SP (* (- EP SP) (/ 87.0 100.0)) )
(+ SP (* (- EP SP) (/ 88.0 100.0)) )
(+ SP (* (- EP SP) (/ 89.0 100.0)) )
(+ SP (* (- EP SP) (/ 90.0 100.0)) )
(+ SP (* (- EP SP) (/ 91.0 100.0)) )
(+ SP (* (- EP SP) (/ 92.0 100.0)) )
(+ SP (* (- EP SP) (/ 93.0 100.0)) )
(+ SP (* (- EP SP) (/ 94.0 100.0)) )
(+ SP (* (- EP SP) (/ 95.0 100.0)) )
(+ SP (* (- EP SP) (/ 96.0 100.0)) )
(+ SP (* (- EP SP) (/ 97.0 100.0)) )
(+ SP (* (- EP SP) (/ 98.0 100.0)) )
(+ SP (* (- EP SP) (/ 99.0 100.0)) )
EP
)
)
(SetQ dist (Vl-Sort-I params
(Function
(Lambda (a b)
(>= (Distance POINT (VLAX-Curve-GetPointAtParam CURVE a))
(Distance POINT (VLAX-Curve-GetPointAtParam CURVE b))
)
)
)
)
)
(If (> (- EP SP) TOL)
(FurthestParameter
(If (< (Nth (Car dist) params) (Nth (Cadr dist) params))
(Nth (Car dist) params)
(If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth (Car dist) params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr dist) params)) 1e-8))
(Nth (Cadr dist) params)
(Nth (Caddr dist) params)
)
)
(If (< (Nth (Car dist) params) (Nth (Cadr dist) params))
(If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth (Car dist) params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr dist) params)) 1e-8))
(Nth (Cadr dist) params)
(Nth (Caddr dist) params)
)
(Nth (Car dist) params)
)
TOL
)
(Nth (Car dist) params)
)
)
(VLAX-Curve-GetPointAtParam CURVE (FurthestParameter (VLAX-Curve-GetStartParam CURVE) (VLAX-Curve-GetEndParam CURVE) TOL) )
)
(defun vlax-curve-getfurthestpointfrom ( ent pt / elst etype )
(setq elst (entget ent))
(cond
( (= "XLINE" (setq etype (cdr (assoc 0 elst))))
nil
)
( (= "RAY" (setq etype (cdr (assoc 0 elst))))
nil
)
( (= "LINE" etype)
(if (< (distance pt (cdr (assoc 10 elst)))
(distance pt (cdr (assoc 11 elst)))
)
(cdr (assoc 11 elst))
(cdr (assoc 10 elst))
)
)
( (and
(= "CIRCLE" etype)
(equal pt (cdr (assoc 10 elst)) 1e-8)
)
(polar pt 0.0 (cdr (assoc 40 elst)))
)
( (and
(= "ELLIPSE" etype)
(equal pt (cdr (assoc 10 elst)) 1e-8)
)
(ZF-GetFurthestPointFrom ent (mapcar '+ pt (list 1e-2 1e-2 0.0)) 1e-8)
)
( (and
(= "LWPOLYLINE" etype)
(vl-every '(lambda ( x ) (or (/= 42 (car x)) (zerop (cdr x)))) elst)
)
(car
(vl-sort (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) elst))
(function
(lambda ( a b ) (> (distance pt a) (distance pt b)))
)
)
)
)
( t
(ZF-GetFurthestPointFrom ent pt 1e-8)
)
)
)
((= "CIRCLE" etype)
((lambda (p c r)
(polar p (angle p c) (* 2. r))
)
(vlax-curve-getclosestpointto curve point)
(cdr (Assoc 10 elst))
(cdr (assoc 40 elst))
)
)
For Circle , this way ?Code: [Select]((= "CIRCLE" etype)
((lambda (p c r)
(polar p (angle p c) (* 2. r))
)
(vlax-curve-getclosestpointto curve point)
(cdr (Assoc 10 elst))
(cdr (assoc 40 elst))
)
)
Glad you can be in favor of .For Circle , this way ?Code: [Select]((= "CIRCLE" etype)
((lambda (p c r)
(polar p (angle p c) (* 2. r))
)
(vlax-curve-getclosestpointto curve point)
(cdr (Assoc 10 elst))
(cdr (assoc 40 elst))
)
)
Yes, chlh_jd, that would sure solve the case, but I wonder how no one didn't saw that in my code - Zoltan's also is written (repeat (1- samples) ...), and should be (repeat samples ...)... So here is my slightly modifications :
Glad you can be in favor of .
However , If distance from point to curve is far enough away, such as must use light-years to desribe , this maximum distance lost meaning . I guess this is why autocad put the 'getfurthestpointfrom' function into .
And finally make sure checked point is transformed into WCS coordinates before calculations begin (trans point 1 0) - so you may start function no matter what UCS is currently active...
(Defun MR-Curve-GetFurthestPointFromCircle ( CURVE POINT / osm cmde samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag pt )
(SetQ samples 200
tolerance 1e-8
)
(Defun FurthestParameter (SP EP / seg params par furthest f ff ci cidata rad r rr k )
(SetQ params (List SP))
(SetQ seg 0.0)
(Defun IsFurther ( A B P )
(>= (Distance A P) (Distance B P))
)
(Repeat samples
(SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
)
(SetQ furthest (Car (SetQ par
(Vl-Sort-I
params
(Function
(Lambda (a b)
(IsFurther
(VLAX-Curve-GetPointAtParam CURVE a)
(VLAX-Curve-GetPointAtParam CURVE b)
POINT
)
)
)
))
)
)
(setq f (nth furthest params))
(If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
(setq ff (FurthestParameter
(If (< (Nth furthest params) (Nth (Cadr par) params))
(Nth furthest params)
(If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
(Nth (Cadr par) params)
(Nth (Caddr par) params)
)
)
(If (< (Nth furthest params) (Nth (Cadr par) params))
(If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
(Nth (Cadr par) params)
(Nth (Caddr par) params)
)
(Nth furthest params)
)
))
(setq ff (Nth furthest params))
)
ff
)
(Setq pt
(VLAX-Curve-GetPointAtParam
CURVE
(FurthestParameter
(VLAX-Curve-GetStartParam CURVE)
(VLAX-Curve-GetEndParam CURVE)
)
)
)
(setq cmde (getvar 'cmdecho))
(setq osm (getvar 'osmode))
(setvar 'cmdecho 0)
(setvar 'osmode 0)
(vl-cmdf "_.CIRCLE" (trans point 0 1) (trans pt 0 1))
(setq rad (cdr (assoc 40 (setq cidata (entget (setq ci (entlast)))))))
(setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
(setq k 0.0)
(while (> (length pt) 3)
(setq r (+ rad (* 1e-4 (setq k (1+ k)))))
(entmod (subst (cons 40 r) (assoc 40 cidata) cidata))
(entupd ci)
(setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
)
(setq k 0.0)
(setq r (cdr (assoc 40 cidata)))
(while (/= (length pt) 3)
(setq rr (- r (* 1e-8 (setq k (1+ k)))))
(entmod (subst (cons 40 rr) (assoc 40 cidata) cidata))
(entupd ci)
(setq pt (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
)
(entdel ci)
(setvar 'osmode osm)
(setvar 'cmdecho cmde)
(list (car pt) (cadr pt) (caddr pt))
)
(defun vlax-curve-getfurthestpointfrom2d ( CURVE POINT / elst etype 2dtype lstn )
(Defun IsFurther ( A B P )
(>= (Distance A P) (Distance B P))
)
(defun _polyvertices ( lst )
(_vertices2 (entnext (cdr (assoc -1 lst))))
)
(defun _vertices2 ( e )
(if (eq "VERTEX" (cdr (assoc 0 (entget e))))
(progn
(setq lstn (cons (assoc 10 (entget e)) lstn))
(setq lstn (cons (assoc 42 (entget e)) lstn))
(_vertices2 (entnext e))
)
)
(reverse lstn)
)
(defun member-fuzz (expr lst fuzz)
(while (and lst (not (equal (car lst) expr fuzz)))
(setq lst (cdr lst))
)
lst
)
(defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
(setq enpar (vlax-curve-getendparam ent))
(setq n -1)
(repeat (fix enpar)
(setq n (1+ n))
(setq p1 (vlax-curve-getpointatparam ent (float n)))
(setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
(setq bulge (vla-getbulge (if (eq (type ent) 'ENAME) (vlax-ename->vla-object ent) ent) (float n)))
(if (/= bulge 0.0)
(progn
(setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
(setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
(setq cenlst (cons cen cenlst))
)
)
)
(reverse cenlst)
)
(SetQ elst (entget CURVE))
(SetQ etype (Cdr (Assoc 0 elst)))
(Cond
((And
(= "ARC" etype)
(Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
)
(MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
(= "CIRCLE" etype)
(Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
)
(MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
(= "ELLIPSE" etype)
(Equal POINT (Cdr (Assoc 10 elst)) 1e-8)
)
(MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
(= "LWPOLYLINE" etype)
(VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
)
(Car
(VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
(Function (Lambda ( a b ) (IsFurther a b POINT)) )
)
)
)
((And
(= "LWPOLYLINE" etype)
(not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
(member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8)
)
(MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
(= "LWPOLYLINE" etype)
(not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
(not (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8))
)
(MR-Curve-GetFurthestPointFromCircle CURVE POINT)
)
((And
(= "POLYLINE" etype)
(SetQ 2dtype (Cdr (Assoc 100 (Reverse elst))))
(SetQ elst (_polyvertices elst))
(not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
(and (= 2dtype "AcDb2dPolyline") (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8))
)
(MR-Curve-GetFurthestPointFromCircle CURVE (Mapcar '+ POINT (List -1e-3 -1e-3 0.0)))
)
((And
(= "POLYLINE" etype)
(not (VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst))
(not (member-fuzz POINT (_plcents (if vla-curve vla-CURVE CURVE)) 1e-8))
)
(MR-Curve-GetFurthestPointFromCircle CURVE POINT)
)
((And
(= "POLYLINE" etype)
(VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
)
(Car
(VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
(Function (Lambda ( a b ) (IsFurther a b POINT)) )
)
)
)
(T
(MR-Curve-GetFurthestPointFromCircle CURVE POINT)
)
)
)
(Defun MR-Curve-GetFurthestPointFrom ( CURVE POINT / samples tolerance IsFurther FurthestParameter elst etype cent rad vec mag )
(SetQ samples 200
tolerance 1e-14
)
(Defun FurthestParameter (SP EP / seg params par furthest f ff )
(SetQ params (List SP))
(SetQ seg 0.0)
(Defun IsFurther ( A B P )
(>= (Distance A P) (Distance B P))
)
(Repeat samples
(SetQ params (Cons (+ SP (SetQ seg (+ seg (/ (- EP SP) samples)))) params))
)
(SetQ furthest (Car (SetQ par
(Vl-Sort-I
params
(Function
(Lambda (a b)
(IsFurther
(VLAX-Curve-GetPointAtParam CURVE a)
(VLAX-Curve-GetPointAtParam CURVE b)
POINT
)
)
)
))
)
)
(setq f (nth furthest params))
(If (and (/= f ff) (> (- (VLAX-Curve-GetDistAtParam CURVE EP) (VLAX-Curve-GetDistAtParam CURVE SP)) tolerance))
(setq ff (FurthestParameter
(If (< (Nth furthest params) (Nth (Cadr par) params))
(Nth furthest params)
(If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
(Nth (Cadr par) params)
(Nth (Caddr par) params)
)
)
(If (< (Nth furthest params) (Nth (Cadr par) params))
(If (not (equal (VLAX-Curve-GetPointAtParam CURVE (Nth furthest params)) (VLAX-Curve-GetPointAtParam CURVE (Nth (Cadr par) params)) 1e-8))
(Nth (Cadr par) params)
(Nth (Caddr par) params)
)
(Nth furthest params)
)
))
(setq ff (Nth furthest params))
)
ff
)
(VLAX-Curve-GetPointAtParam
CURVE
(FurthestParameter
(VLAX-Curve-GetStartParam CURVE)
(VLAX-Curve-GetEndParam CURVE)
)
)
)
(defun vlax-curve-getfurthestpointfrom3d ( CURVE POINT / elst etype 2dtype lstn )
(Defun IsFurther ( A B P )
(>= (Distance A P) (Distance B P))
)
(defun _polyvertices ( lst )
(_vertices2 (entnext (cdr (assoc -1 lst))))
)
(defun _vertices2 ( e )
(if (eq "VERTEX" (cdr (assoc 0 (entget e))))
(progn
(setq lstn (cons (assoc 10 (entget e)) lstn))
(setq lstn (cons (assoc 42 (entget e)) lstn))
(_vertices2 (entnext e))
)
)
(reverse lstn)
)
(defun member-fuzz (expr lst fuzz)
(while (and lst (not (equal (car lst) expr fuzz)))
(setq lst (cdr lst))
)
lst
)
(defun _plcents ( ent / enpar n p1 p2 bulge rad cen cenlst )
(setq enpar (vlax-curve-getendparam ent))
(setq n -1)
(repeat (fix enpar)
(setq n (1+ n))
(setq p1 (vlax-curve-getpointatparam ent (float n)))
(setq p2 (vlax-curve-getpointatparam ent (float (1+ n))))
(setq bulge (vla-getbulge (vlax-ename->vla-object ent) (float n)))
(if (/= bulge 0.0)
(progn
(setq rad (/ (distance p1 p2) (* 2 (sin (* 2 (atan bulge))))))
(setq cen (polar p1 (+ (angle p1 p2) (- (/ pi 2.0) (* 2 (atan bulge)))) rad))
(setq cenlst (cons cen cenlst))
)
)
)
(reverse cenlst)
)
(SetQ elst (entget CURVE))
(SetQ etype (Cdr (Assoc 0 elst)))
(Cond
((= "XLINE" etype)
nil
)
((= "RAY" etype)
nil
)
((= "LINE" etype)
(If (IsFurther (Cdr (Assoc 10 elst)) (Cdr (Assoc 11 elst)) POINT)
(Cdr (Assoc 10 elst))
(Cdr (Assoc 11 elst))
)
)
((And
(= "POLYLINE" etype)
(VL-Every (Function (Lambda ( x ) (Or (/= 42 (Car x)) (ZeroP (Cdr x))))) elst)
)
(Car
(VL-Sort (MapCar (Function Cdr) (VL-Remove-If-Not (Function (Lambda ( x ) (= 10 (Car x)))) elst))
(Function (Lambda ( a b ) (IsFurther a b POINT)) )
)
)
)
(T
(MR-Curve-GetFurthestPointFrom CURVE POINT)
)
)
)
;; Vector Cross Product - Lee Mac
;; Args: u,v - vectors in R^3
(defun v^v ( u v )
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(- (* (car v) (caddr u)) (* (car u) (caddr v)))
(- (* (car u) (cadr v)) (* (car v) (cadr u)))
)
)
;; Collinear-p - Lee Mac
;; Returns T if p1,p2,p3 are collinear
(defun LM:Collinear-p ( p1 p2 p3 )
(
(lambda ( a b c )
(or
(equal (+ a b) c 1e-8)
(equal (+ b c) a 1e-8)
(equal (+ c a) b 1e-8)
)
)
(distance p1 p2) (distance p2 p3) (distance p1 p3)
)
)
;; Project Point onto Plane - Lee Mac
;; Projects pt onto the plane defined by its origin and normal
(defun LM:ProjectPointToPlane ( pt org nm )
(setq pt (trans pt 0 nm)
org (trans org 0 nm)
)
(trans (list (car pt) (cadr pt) (caddr org)) nm 0)
)
(defun vlax-curve-getfurthestpointfrom ( curve point / vla-curve flagarc flaglw cmde pt pt1 pt2 pt3 pt4 )
(setq cmde (getvar 'cmdecho))
(if (eq (type curve) 'VLA-OBJECT)
(progn
(setq vla-curve curve)
(setq curve (vlax-vla-object->ename vla-curve))
)
)
(if (eq (cdr (assoc 0 (entget curve))) "ARC")
(progn
(setq flagarc T)
(setvar 'cmdecho 0)
(vl-cmdf "_.COPY" curve "" '(0.0 0.0 0.0) '(0.0 0.0 0.0))
(vl-cmdf "_.PEDIT" (entlast) "" "")
(setq curve (entlast))
(setvar 'cmdecho cmde)
)
)
(if (eq (cdr (assoc 0 (entget curve))) "LWPOLYLINE")
(progn
(setq flaglw T)
(setvar 'cmdecho 0)
(vl-cmdf "_.CONVERTPOLY" "H" curve "")
(setq vla-curve (vlax-ename->vla-object curve))
(setvar 'cmdecho cmde)
)
)
(setq pt1 (vlax-curve-getpointatparam curve (+ (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve)) (* 1.0 (/ (- (if (not (vl-catch-all-apply 'vlax-curve-getendparam (list curve))) 3.0 (vlax-curve-getendparam curve)) (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve))) 3.0)))))
(setq pt2 (vlax-curve-getpointatparam curve (+ (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve)) (* 2.0 (/ (- (if (not (vl-catch-all-apply 'vlax-curve-getendparam (list curve))) 3.0 (vlax-curve-getendparam curve)) (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve))) 3.0)))))
(setq pt3 (vlax-curve-getpointatparam curve (+ (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve)) (* 3.0 (/ (- (if (not (vl-catch-all-apply 'vlax-curve-getendparam (list curve))) 3.0 (vlax-curve-getendparam curve)) (if (not (vl-catch-all-apply 'vlax-curve-getstartparam (list curve))) 0.0 (vlax-curve-getstartparam curve))) 3.0)))))
(setq pt4 (vlax-curve-getstartpoint curve))
(if (and (not (LM:Collinear-p pt1 pt2 pt3)) (not (LM:Collinear-p pt1 pt2 pt4)) (vlax-curve-isplanar curve))
(cond ((not (and (equal (caddr pt1) 0.0 1e-8) (equal (caddr pt2) 0.0 1e-8) (equal (caddr pt3) 0.0 1e-8) (equal (caddr pt4) 0.0 1e-8)))
(progn
(setvar 'cmdecho 0)
(vl-cmdf "_.UCS" "w")
(vl-cmdf "_.UCS" "za" "" (v^v (mapcar '- pt2 pt1) (mapcar '- pt3 pt1)))
(vl-cmdf "_.UCS" "m" (trans pt1 0 1))
(setq pt (vlax-curve-getfurthestpointfrom2d curve (LM:ProjectPointToPlane point (trans '(0.0 0.0 0.0) 1 0) (mapcar '- (trans '(0.0 0.0 1.0) 1 0) (trans '(0.0 0.0 0.0) 1 0)))))
(vl-cmdf "_.UCS" "p")
(vl-cmdf "_.UCS" "p")
(vl-cmdf "_.UCS" "p")
(setvar 'cmdecho cmde)
))
((and (equal (caddr pt1) 0.0 1e-8) (equal (caddr pt2) 0.0 1e-8) (equal (caddr pt3) 0.0 1e-8) (equal (caddr pt4) 0.0 1e-8) (eq (getvar 'worlducs) 0))
(progn
(setvar 'cmdecho 0)
(vl-cmdf "_.UCS" "w")
(setq pt (vlax-curve-getfurthestpointfrom2d curve (LM:ProjectPointToPlane point '(0.0 0.0 0.0) '(0.0 0.0 1.0))))
(vl-cmdf "_.UCS" "p")
(setvar 'cmdecho cmde)
))
((and (equal (caddr pt1) 0.0 1e-8) (equal (caddr pt2) 0.0 1e-8) (equal (caddr pt3) 0.0 1e-8) (equal (caddr pt4) 0.0 1e-8) (eq (getvar 'worlducs) 1))
(setq pt (vlax-curve-getfurthestpointfrom2d curve (LM:ProjectPointToPlane point '(0.0 0.0 0.0) '(0.0 0.0 1.0))))
)
)
(setq pt (vlax-curve-getfurthestpointfrom3d curve point))
)
(setvar 'cmdecho 0)
(gc)
(if flaglw (vl-cmdf "_.CONVERTPOLY" "L" curve ""))
(if flagarc (vl-cmdf "_.ERASE" (entlast) ""))
(setvar 'cmdecho cmde)
pt
)
The code was completely updated, it may not work with LWPOLYLINE or POLYLINE VLA-OBJECT with ARC-s... Also XLINE or RAY curve objects may break function, but their furthest point from is in infinity, so never mind; all other cases are computed... Also LWPOLYLINE curve is during execution of function converted to HEAVY POLYLINE, because of bug, but after it's converted back to LWPOLYLINE...
Sincerely, M.R.
Now I didn't know it doing yet , but still in favor of you improving this function . :-)Glad you can be in favor of .I intended to create this function with some purpose in process of working with AutoCAD. I guess no one will draw entities so far away from checked point... As a matter a fact I already posted one possible usage of this function on www.cadtutor.net (you may google it) and it was with normal demands of CAD (Computer Aided Design)...
However , If distance from point to curve is far enough away, such as must use light-years to desribe , this maximum distance lost meaning . I guess this is why autocad put the 'getfurthestpointfrom' function into .
((= "ARC" etype)
((lambda (p c r)
(vlax-curve-getclosestpointto curve (polar p (angle p c) (+ r r)))
)
(vlax-curve-getclosestpointto curve point)
(cdr (assoc 10 elst))
(cdr (assoc 40 elst))
)
)
Now I didn't know it doing yet , but still in favor of you improving this function . :-)
For Arc perhapsCode: [Select]((= "ARC" etype)
((lambda (p c r)
(vlax-curve-getclosestpointto curve (polar p (angle p c) (+ r r)))
)
(vlax-curve-getclosestpointto curve point)
(cdr (assoc 10 elst))
(cdr (assoc 40 elst))
)
)
((= "ELLIPSE" etype)
((lambda (p1 p2 e / foo ang a b)
(defun foo (p a b / m n c aa bb cc dd ee xl)
;;get furthest point of ellipse which is initialized by Origin and X-axis .
(setq m (car p)
n (cadr p)
c (- (* a a) (* b b))
aa (* c c)
bb (* -2 m a a c)
cc (+ (* n n a a b b) (* m m a a a a) (* -1. a a c c))
dd (* 2 m a a a a c)
ee (* -1. m m (expt a 6))
xl (->eq^4 aa bb cc dd ee)
xl (mapcar
(function
(lambda (x / z)
(setq z (* b (sqrt (- 1. (expt (/ x a) 2)))))
(list (list x z) (list x (- z)))))
xl)
xl (apply 'append xl))
(car
(vl-sort xl
(function (lambda (e1 e2)
(> (distance p e1) (distance p e2))))))
)
(setq ang (angle p2 (list 0 0 0))
a (distance p2 (list 0 0 0))
b (* a e))
(vlax-curve-getclosestpointto
curve
(gsls-ab->xy (foo (gsls-xy->ab p p1 ang) a b) p1 ang))
)
(cdr (assoc 10 elst))
(cdr (assoc 11 elst))
(cdr (assoc 40 elst))
)
)
;;;将点AB坐标换算为XY坐标,AB坐标的原点为PT0,转角为R0
;;;X=X0+AcosR0-BsinR0
;;;Y=Y0+AsinR0+BcosR0
(defun gsls-AB->XY (pt pt0 ANG / X Y)
(setq X (+ (car pt0)
(* (car pt) (cos ANG))
(* -1 (cadr pt) (sin ANG))
)
Y (+ (cadr pt0)
(* (car pt) (sin ANG))
(* (cadr pt) (cos ANG))
)
)
(list X Y 0.0)
)
;;;将点XY坐标换算为AB坐标,AB坐标的原点为PT0,转角为R0
;;;A=(X-X0)cosR0+(Y-Y0)sinR0
;;;B=(Y-Y0)cosR0-(X-X0)sinR0
(defun gsls-XY->AB (pt pt0 ANG / A B)
(setq A (+ (* (- (car pt) (car pt0)) (cos ANG))
(* (- (cadr pt) (cadr pt0)) (sin ANG))
)
B (- (* (- (cadr pt) (cadr pt0)) (cos ANG))
(* (- (car pt) (car pt0)) (sin ANG))
)
)
(list A B 0.0)
)
It can be solve by New ELLipse equation which not need trans the point .[(x-x0)cosθ+(y-y0)sinθ]²/a² + [(y-y0)cosθ-(x-x0)sinθ]²/b²=1
((= "ELLIPSE" etype)
;;For 3d method
((lambda (p1 p2 e norm / foo ang a b p)
(defun foo (p a b / m n c aa bb cc dd ee xl)
;;get furthest point of ellipse which is initialized by Origin and X-axis .
(setq m (car p)
n (cadr p)
c (- (* a a) (* b b))
aa (* c c)
bb (* -2 m a a c)
cc (+ (* n n a a b b) (* m m a a a a) (* -1. a a c c))
dd (* 2 m a a a a c)
ee (* -1. m m (expt a 6))
xl (->eq^4 aa bb cc dd ee)
xl (mapcar
(function
(lambda (x / z)
(setq z (* b (sqrt (- 1. (expt (/ x a) 2)))))
(list (list x z) (list x (- z)))))
xl)
xl (apply 'append xl))
(car
(vl-sort xl
(function (lambda (e1 e2)
(> (distance p e1) (distance p e2))))))
)
(setq a (distance p2 (list 0 0 0))
b (* a e)
p (mapcar (function -) (trans point 0 norm) (trans p1 0 norm))
p (foo (list (cadr p) (- (car p))) a b)
p (trans (mapcar (function +) (list (- (cadr p)) (car p) 0.0) (trans p1 0 norm)) norm 0))
(vlax-curve-getclosestpointto curve p)
)
(cdr (assoc 10 elst))
(cdr (assoc 11 elst))
(cdr (assoc 40 elst))
(cdr (assoc 210 elst))
)
)
I think you are tired to edit this function :-DHi ribarm , how about new for Ellipse .I found the code I often is not really work for 3D, and it's Accuracy just 1e-3 , perhaps by solve the equation method has much deviation .Code: [Select]((= "ELLIPSE" etype)
I think you are tired to edit this function :-D
;;For 3d method
((lambda (p1 p2 e norm / foo ang a b p)
(defun foo (p a b / m n c aa bb cc dd ee xl)
;;get furthest point of ellipse which is initialized by Origin and X-axis .
... )
The vla-intersectwith method will take so much time in recursion , perhaps this way : get boundingbox , cal max included circle ,and then cal the point of the circle which closest to the given curve .
((= "ARC" etype)
((lambda (p c)
(vlax-curve-getclosestpointto
curve
(pt+ p (pt* (pt- c p) 2.)))
)
(vlax-curve-getclosestpointto curve point)
(cdr (assoc 10 elst))
)
)
((= "CIRCLE" etype)
((lambda (p c)
(vlax-curve-getclosestpointto curve (pt+ p (pt* (pt- c p) 2.)))
)
(vlax-curve-getclosestpointto curve point)
(cdr (Assoc 10 elst))
)
)
;;;Vector +
(defun pt+ (pt1 pt2)
(mapcar (function +)
pt1
pt2
)
)
;;;Vector -
(defun pt- (pt2 pt1)
(mapcar (function -)
pt2
pt1
)
)
;;;Vector *
(defun pt* (v sc)
(mapcar (function (lambda (x)
(* x sc)
)
)
v
)
)
(defun c:test (/ en pt p2)
(setq en (car (entsel)))
(setq pt (trans (getpoint) 1 0))
(if (setq p2 (getfurthestpointfrom en pt))
(progn
(entmake (list (cons 0 "LINE")
(cons 10 pt)
(cons 11 p2)
(cons 62 1)))
(princ (strcat "\n Maxdistance = " (rtos (distance pt p2) 2 8)))
))
(princ)
)
(defun getfurthestpointfrom (en pt / en ent etype pt p1 p R p2 d d1 d2 p3 p4 p5 p6)
;;; GetFurthestpointfrom for 3D curve .
;;; For Periodic Curve ( not for LINE , Xline ...)
;;; GSLS(SS) 2012-9-13
(if (and en
pt
(setq ent (entget en))
(not (member (setq etype (strcase (dxf 0 ent))) (list "LINE" "XLINE" "RAY"))))
(progn
((lambda (obj / minpt maxpt box)
(vla-GetBoundingBox
obj
(quote minpt)
(quote maxpt))
(setq minPt (vlax-safearray->list minPt)
maxPt (vlax-safearray->list maxPt))
(setq box (vlex-ex2con (list minpt maxpt)))
(setq
p (car
(vl-sort
box
(function
(lambda (p1 p2)
(> (distance pt p1) (distance pt p2)))))))
(vlax-release-object obj))
(vlax-ename->vla-object en))
(setq R (distance pt p)
p2 (vlax-curve-getclosestpointto en p))
(setq d (distance pt p2))
(while (< d
(setq
d1 (distance pt
(setq p3
(vlax-curve-getclosestpointto
en
(pt+
pt
(pt* (v2u (mapcar (function -) p2 pt))
r)))))))
(setq d d1
p2 p3))
(while
(< d
(setq
d1 (distance
pt
(setq
p4 (vlax-curve-getclosestpointto
en
(midpt p2 p3))))))
(setq d d1
p3 p2
p2 p4))
(while (or (< d
(setq d1
(distance
pt
(setq p5 (vlax-curve-getclosestpointto
en
(midpt p2 p4))))))
(< d
(setq d2
(distance
pt
(setq p6 (vlax-curve-getclosestpointto
en
(midpt p3 p4)))))))
(if p6
(setq d d2
p2 p4)
(setq d d1
p3 p4))
(setq p4 (vlax-curve-getclosestpointto en (midpt p2 p3))
p5 nil
p6 nil)))
(if (= etype "LINE")
(if (> (distance pt (setq p1 (dxf 10 ent))) (distance pt (setq p2 (dxf 11 ent))))
(setq p2 p1)))
)
p2
)
;;;-----------------------------
;;; Use functions
(defun dxf (n l)
(cdr (assoc n l)))
(defun midpt (pta ptb)
(mapcar (function (lambda (x y)
(/ (+ x y) 2.0)
)
)
pta
ptb
)
)
;;;Vector +
(defun pt+ (pt1 pt2)
(mapcar (function +)
pt1
pt2
)
)
;;;Vector -
(defun pt- (pt2 pt1)
(mapcar (function -)
pt2
pt1
)
)
;;;Vector *
(defun pt* (v sc)
(mapcar (function (lambda (x)
(* x sc)
)
)
v
)
)
;;; Vector Unit
(defun v2u (v / d)
(setq d (sqrt (apply (function +) (mapcar (function *) v v))))
(if (/= d 0)
(mapcar (function (lambda (x) (/ x d))) v)
)
)
(defun vlex-ex2con (pts / 2dbox)
(defun 2dbox (p1 p2)
(list p1
(cons (car p2) (cdr p1))
p2
(cons (car p1) (cdr p2))))
(setq pts (mapcar (function (lambda (x) (trans x 0 0))) pts))
(if (= (caddar pts) (caddr (cadr pts)))
(2dbox (car pts) (cadr pts))
(append
(2dbox
(car pts)
(list (caadr pts) (cadadr pts) (caddar pts)))
(2dbox
(list (caar pts) (cadar pts) (caddr (cadr pts)))
(cadr pts)))
))
(defun vlax-curve-getfurthestpointfrom ( curve pt / _precise LM:ProjectPointToPlane
sd ed dd p1 p2 d1 d2 d p pc rad ci k r rr )
(setq sd (vlax-curve-getdistatparam curve (vlax-curve-getstartparam curve)))
(setq ed (vlax-curve-getdistatparam curve (vlax-curve-getendparam curve)))
(setq p1 T p2 T dd 0.0)
(while (and p1 p2)
(setq p1 (vlax-curve-getpointatdist curve (+ sd dd)))
(setq dd (+ dd (/ ed 100.0)))
(setq d1 (distance pt p1))
(setq p2 (vlax-curve-getpointatdist curve (+ sd dd)))
(if (>= (+ sd dd) ed) (setq p2 (vlax-curve-getendpoint curve)))
(setq d2 (distance pt p2))
(if (null p) (setq p p1))
(if (> d1 (distance pt p)) (setq p p1))
(if (> d2 (distance pt p)) (setq p p2))
(if (> (+ sd dd) ed) (setq p1 nil p2 nil))
)
(defun _precise ( fact / p1 p2 dd d )
(setq p1 T p2 T dd 0.0 d nil)
(while (and p1 p2)
(if (not (equal p (vlax-curve-getstartpoint curve) 1e-8))
(progn
(setq p1 (vlax-curve-getpointatdist curve (+ (if (null d) (setq d (- (vlax-curve-getdistatpoint curve p) (/ ed fact))) d) dd)))
(setq dd (+ dd (/ ed fact 100.0)))
(setq d1 (distance pt p1))
(setq p2 (vlax-curve-getpointatdist curve (+ d dd)))
(if (>= (+ d dd) ed) (setq p2 (vlax-curve-getendpoint curve)))
(setq d2 (distance pt p2))
(if (> d2 d1) (setq p p2) (setq p1 nil p2 nil))
)
(setq p1 nil p2 nil)
)
)
)
(_precise (expt 100.0 1.0))
(_precise (expt 100.0 2.0))
(_precise (expt 100.0 3.0))
(_precise (expt 100.0 4.0))
(_precise (expt 100.0 5.0))
(_precise (expt 100.0 6.0))
(_precise (expt 100.0 7.0))
(_precise (expt 100.0 8.0))
(_precise (expt 100.0 9.0))
(_precise (expt 100.0 10.0))
(defun LM:ProjectPointToPlane ( pt org nm )
(setq pt (trans pt 0 nm)
org (trans org 0 nm)
)
(trans (list (car pt) (cadr pt) (caddr org)) nm 0)
)
(if (eq (vlax-curve-isplanar curve) T)
(progn
(setq pc (LM:ProjectPointToPlane pt (vlax-curve-getstartpoint curve) (cdr (assoc 210 (entget curve)))))
(setq rad (distance pc p))
(setq pc (trans pc 0 (cdr (assoc 210 (entget curve)))))
(setq ci (entmakex (list (cons 0 "CIRCLE") (cons 10 pc) (cons 40 rad) (assoc 210 (entget curve)))))
(setq cid (entget ci))
(while (not (setq p (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone)))
(entmod (subst (list 10 (if (equal (cadr (assoc 10 cid)) 0.0 1e-8) 0.0 (cadr (assoc 10 cid))) (if (equal (caddr (assoc 10 cid)) 0.0 1e-8) 0.0 (caddr (assoc 10 cid))) (if (equal (cadddr (assoc 10 cid)) 0.0 1e-8) 0.0 (cadddr (assoc 10 cid)))) (assoc 10 cid) cid))
(entupd ci)
)
(setq k 0.0)
(while (> (length p) 3)
(setq r (+ rad (* 5e-8 (setq k (1+ k)))))
(entmod (subst (cons 40 r) (assoc 40 cid) cid))
(entupd ci)
(setq p (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
)
(setq k 0.0)
(setq r (cdr (assoc 40 (entget ci))))
(while (/= (length p) 3)
(setq rr (- r (* 5e-11 (setq k (1+ k)))))
(entmod (subst (cons 40 rr) (assoc 40 cid) cid))
(entupd ci)
(setq p (vlax-invoke (vlax-ename->vla-object curve) 'IntersectWith (vlax-ename->vla-object ci) acExtendNone))
)
(entdel ci)
p
)
p
)
)