;对于椭圆及SPLine可以用下面函数取点:
;; get point set of a closed curve by order
;; this function you improve by yourself acordding your need .
(defun get-closed-curve-pts (en / ent et)
;;by GSLS(SS)
(setq
ent (entget en)
et (cdr (assoc 0 ent))
)
(cond
((= et "LWPOLYLINE")
((lambda (/ a b vetex bu p1 p2 l r ang an1 N)
(while (setq ent (member (assoc 10 ent) ent))
(setq b (cons (cdar ent) b)
ent (member (assoc 42 ent) ent)
b (cons (cdar ent) b)
ent (cdr ent)
vetex (cons b vetex)
b nil
)
)
(while vetex
(setq a (car vetex)
vetex (cdr vetex)
bu (car a)
p1 (cadr a)
)
(if l
(setq p2 (car l))
(setq p2 (cadr (last vetex))
l (cons p2 l)
)
)
(if (equal bu 0 1e-6)
(setq l (cons p1 l))
(progn
(setq ang (* 2 (atan bu))
r (/ (distance p1 p2)
(* 2 (sin ang))
)
c (polar p1
(+ (angle p1 p2) (- (/ pi 2) ang))
r
)
r (abs r)
ang (abs (* ang 2.0))
N (abs (fix (/ ang 0.0174532925199433)))
)
(if (= N 0)
(setq l (cons p1 l))
(progn
(setq an1 (/ ang N)
ang (angle c p2)
)
(if (not (minusp bu))
(setq an1 (- an1))
)
(repeat (1- N)
(setq ang (+ ang an1))
(setq l (cons (polar c ang r) l))
)
(setq l (cons p1 l))
)
)
)
)
)
l
)
)
)
((= et "CIRCLE")
((lambda (c R / sa ptl)
(setq sa 0.0)
(repeat 180
(setq ptl (cons (polar c sa R) ptl)
sa (+ sa 0.0174532925199433)
)
)
(setq ptl (reverse ptl))
(append
ptl
(mapcar (function
(lambda (p)
(mapcar (function +) c (mapcar (function -) c p))
)
)
ptl
)
)
)
(cdr (assoc 10 ent))
(cdr (assoc 40 ent))
)
)
((= et "SPLINE")
((lambda (/ r l _oce)
(setq _oce (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(if (vl-catch-all-apply
(function vl-cmdf)
(list "_PEDIT"
(vlax-vla-object->ename
(vla-copy (vlax-ename->vla-object en))
)
""
10
""
)
)
(progn
(setq l (ss-assoc 10 (entget (setq r (entlast)))))
(if (vlax-curve-isClosed r)
(setq l (append l (list (car l))))
)
(entdel r)
)
)
(setvar "CMDECHO" _oce)
(append l (list (car l)))
)
)
)
((= et "ELLIPSE")
((lambda (/ e l _os)
(setq _os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(vl-catch-all-apply
(function vla-offset)
(list (vlax-ename->vla-object en) 0.1)
)
(setq e (entlast))
(vl-catch-all-apply
(function vla-offset)
(list (vlax-ename->vla-object (entlast)) -0.1)
)
(entdel e)
(setq e (entlast))
(setq l (ss-assoc 10 (entget e)))
(entdel e)
(setvar "OSMODE" _os)
(append l (list (car l)))
)
)
)
)
)
;max circle inside polyline
;Stefan M. 26.07.2012
(defun C:TEST ( / space e l m c o r p offtype)
(setq space (vlax-get (vla-get-ActiveDocument (vlax-get-acad-object)) (if (= (getvar 'cvport) 1) 'PaperSpace 'ModelSpace)))
(setq offtype (getvar 'offsetgaptype))
(setvar 'offsetgaptype 1)
(if (setq e (ssget ":E:S:L" '((0 . "LWPOLYLINE"))))
(progn
(setq e (vlax-ename->vla-object (ssname e 0))
l (list (vla-copy e))
m 0.0
)
(while l
(foreach x l
(if
(setq c (cond ((and
(= (vlax-curve-GetEndParam x) 2.0)
(or
(vl-some 'zerop (mapcar '(lambda (a) (vla-getbulge x a)) '(0 1)))
(<=
(distance
(vlax-curve-GetPointAtParam x 0.5)
(vlax-curve-GetPointAtParam x 1.5)
)
(distance
(vlax-curve-GetPointAtParam x 0.0)
(vlax-curve-GetPointAtParam x 1.0)
)
)
)
)
(mapcar '(lambda (a b) (* 0.5 (+ a b)))
(vlax-curve-GetPointAtParam x 0.5)
(vlax-curve-GetPointAtParam x 1.5)
)
)
((and
(= (vlax-curve-GetEndParam x) 3.0)
(vlax-curve-IsClosed x)
(vl-every 'zerop (mapcar '(lambda (a) (vla-getbulge x a)) '(0 1 2)))
)
(incircle x)
)
((and
(= (vlax-curve-GetEndParam x) 4.0)
(equal '(0. 0. 0.) (mapcar '+ (vlax-curve-GetFirstDeriv x 0.5) (vlax-curve-GetFirstDeriv x 2.5)) 1e-8)
(equal '(0. 0. 0.) (mapcar '+ (vlax-curve-GetFirstDeriv x 1.5) (vlax-curve-GetFirstDeriv x 3.5)) 1e-8)
)
(median x)
)
((< (vla-get-area x) 1e-7) (median x))
)
)
(if
(equal (setq r (distance c (vlax-curve-GetClosestPointTo e c))) m 1e-8)
(setq p (cons (list c r) p))
(if (> r m) (setq p (list (list c r)) m r))
)
(setq o (append (offset_in x) o))
)
(vla-delete x)
)
(setq l o o nil)
)
(foreach x p (vla-put-Color (vla-AddCircle space (vlax-3D-point (car x)) (cadr x)) acRed))
)
)
(setvar 'offsetgaptype offtype)
(princ)
)
(defun incircle (e / a b c p pt)
(setq a (vlax-curve-GetDistAtParam e 1)
b (- (vlax-curve-GetDistAtParam e 2) a)
c (- (setq p (vlax-curve-GetDistAtParam e 3)) a b)
pt (mapcar 'vlax-curve-GetPointAtParam (list e e e) '(2 3 1))
)
(mapcar
'(lambda (x) (/ (apply '+ (mapcar '* (list a b c) x)) p))
(list
(mapcar 'car pt)
(mapcar 'cadr pt)
)
)
)
(defun median (e / i l n)
(repeat
(setq n (fix (setq i (vlax-curve-GetEndParam e))))
(setq l (cons (vlax-curve-GetPointAtParam e (setq n (1- n))) l))
)
(mapcar
'(lambda (x) (/ (apply '+ x) i))
(list
(mapcar 'car l)
(mapcar 'cadr l)
)
)
)
(defun offset_in (e / i)
(setq i (/ (vla-get-Area e) (vla-get-Length e) 10.0))
(apply
'append
(mapcar
(function
(lambda (x / o)
(if
(not (vl-catch-all-error-p (setq o (vl-catch-all-apply 'vlax-invoke (list e 'Offset x)))))
(vl-remove-if
'(lambda (a)
(and
(or
(> (vla-get-Area a) (vla-get-Area e))
(> (vla-get-Length a) (vla-get-Length e))
)
(not (vla-delete a))
)
)
o
)
)
)
)
(list i (- i))
)
)
)
发表于 2013-8-2 18:24:21
置顶卡
变色卡
显身卡
楼主