椭圆（弧）转多段线（非模拟）---
本帖最后由 尘缘一生 于 2021-12-23 16:08 编辑椭圆（弧）转换为多段线弧（非模拟）
;; Arguments
;; lst : a list
;; start : start index (first item = 0)
;; leng : the sub list length (number of items) or nil
(defun sublist (lst start leng / n r)
(if (or (not leng) (< (- (length lst) start) leng))
(setq leng (- (length lst) start))
)
(setq n (+ start leng))
(while (< start n)
(setq r (cons (nth (setq n (1- n)) lst) r))
)
)
;; EllipseToPolyline
;; Returns a polyline (vla-object) which is an approximation of the ellipse (or elliptical arc)
;;
;; Argument : an ellipse (vla-object)(defun EllipseToPolyline (el / cl normcen elv pt0
pt1 pt2 pt3 pt4 ac0 ac4 a04
a02 a24 bsc0bsc2bsc3 bsc4plst
blst spt spa fspasrat ept epa
fepa eratn
)
(vl-load-com)
(setq cl (= (ang<2pi (vla-get-StartAngle el))
(ang<2pi (vla-get-EndAngle el))
)
norm (vlax-get el 'Normal)
cen(trans (vlax-get el 'Center) 0 norm)
elv(caddr cen)
cen(3dTo2dPt cen)
pt0(mapcar '+ (trans (vlax-get el 'MajorAxis) 0 norm) cen)
ac0(angle cen pt0)
pt4(mapcar '+ cen (trans (vlax-get el 'MinorAxis) 0 norm))
pt2(3dTo2dPt
(trans (vlax-curve-getPointAtparam el (/ pi 4.)) 0 norm)
)
ac4(angle cen pt4)
a04(angle pt0 pt4)
a02(angle pt0 pt2)
a24(angle pt2 pt4)
bsc0 (/ (ang<2pi (- a02 ac4)) 2.)
bsc2 (/ (ang<2pi (- a04 a02)) 2.)
bsc3 (/ (ang<2pi (- a24 a04)) 2.)
bsc4 (/ (ang<2pi (- (+ ac0 pi) a24)) 2.)
pt1(inters pt0
(polar pt0 (+ ac0 (/ pi 2.) bsc0) 1.)
pt2
(polar pt2 (+ a02 bsc2) 1.)
nil
)
pt3(inters pt2
(polar pt2 (+ a04 bsc3) 1.)
pt4
(polar pt4 (+ a24 bsc4) 1.)
nil
)
plst (list pt4 pt3 pt2 pt1 pt0)
blst (mapcar '(lambda (b) (tan (/ b 2.)))
(list bsc4 bsc3 bsc2 bsc0)
)
)
(foreach b blst (setq blst (cons b blst)))
(foreach b blst (setq blst (cons b blst)))
(foreach p (cdr plst)
(setq ang(angle cen p)
plst (cons (polar cen (+ ang (* 2 (- ac4 ang))) (distance cen p))
plst
)
)
)
(foreach p (cdr plst)
(setq ang(angle cen p)
plst (cons (polar cen (+ ang (* 2 (- ac0 ang))) (distance cen p))
plst
)
)
)
(setq pl (vlax-invoke
(vla-get-ModelSpace
(vla-get-ActiveDocument (vlax-get-acad-object))
)
'AddLightWeightPolyline
(apply 'append
(setq plst (reverse (if cl
(cdr plst)
plst
)
)
)
)
)
)
(vlax-put pl 'Normal norm)
(vla-put-Elevation pl elv)
(mapcar '(lambda (i v) (vla-SetBulge pl i v))
'(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)
blst
)
(if cl
(vla-put-Closed pl :vlax-true)
(progn (setq spt(vlax-curve-getClosestPointTo pl (vlax-get el 'Startpoint))
spa(vlax-curve-getParamAtPoint pl spt)
fspa (fix spa)
ept(vlax-curve-getClosestPointTo pl (vlax-get el 'Endpoint))
epa(vlax-curve-getParamAtPoint pl ept)
fepa (fix epa)
n 0
)
(cond ((equal spt (trans pt0 norm 0) 1e-9)
(if (= epa fepa)
(setq plst (sublist plst 0 (1+ fepa))
blst (sublist blst 0 (1+ fepa))
)
(setq erat (/ (- (vlax-curve-getDistAtParam pl epa)
(vlax-curve-getDistAtParam pl fepa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17))
(vlax-curve-getDistAtParam pl fepa)
)
)
plst (append (sublist plst 0 (1+ fepa))
(list (3dTo2dPt (trans ept 0 norm)))
)
blst (append (sublist blst 0 (1+ fepa))
(list (k*bulge (nth fepa blst) erat))
)
)
)
)
((equal ept (trans pt0 norm 0) 1e-9)
(if (= spa fspa)
(setq plst (sublist plst fspa nil)
blst (sublist blst fspa nil)
)
(setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl spa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl fspa)
)
)
plst (cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) nil)
)
blst (cons (k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) nil)
)
)
)
)
(T
(setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl spa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
(vlax-curve-getDistAtParam pl fspa)
)
)
erat (/ (- (vlax-curve-getDistAtParam pl epa)
(vlax-curve-getDistAtParam pl fepa)
)
(- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17))
(vlax-curve-getDistAtParam pl fepa)
)
)
)
(if (< epa spa)
(setq plst (append (if (= spa fspa)
(sublist plst fspa nil)
(cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) nil)
)
)
(cdr (sublist plst 0 (1+ fepa)))
(if (/= epa fepa)
(list (3dTo2dPt (trans ept 0 norm)))
)
)
blst (append (if (= spa fspa)
(sublist blst fspa nil)
(cons (k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) nil)
)
)
(sublist blst 0 fepa)
(if (= epa fepa)
(list (nth fepa blst))
(list (k*bulge (nth fepa blst) erat))
)
)
)
(setq plst (append (if (= spa fspa)
(sublist plst fspa (1+ (- fepa fspa)))
(cons (3dTo2dPt (trans spt 0 norm))
(sublist plst (1+ fspa) (- fepa fspa))
)
)
(list (3dTo2dPt (trans ept 0 norm)))
)
blst (append (if (= spa fspa)
(sublist blst fspa (- fepa fspa))
(cons (k*bulge (nth fspa blst) srat)
(sublist blst (1+ fspa) (- fepa fspa))
)
)
(if (= epa fepa)
(list (nth fepa blst))
(list (k*bulge (nth fepa blst) erat))
)
)
)
)
)
)
(vlax-put pl 'Coordinates (apply 'append plst))
(foreach b blst (vla-SetBulge pl n b) (setq n (1+ n)))
)
)
pl
);; Ang<2pi
;; Returns the angle expression betweem 0 and 2*pi
(defun ang<2pi (ang)
(if (and (<= 0 ang) (< ang (* 2 pi)))
ang
(ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))
)
);; 3dTo2dPt
;; Returns the 2d point (x y) of a 3d point (x y z)
(defun 3dTo2dPt (pt) (list (car pt) (cadr pt)));; Tan
;; Returns the angle tangent
(defun tan (a) (/ (sin a) (cos a)))
;; K*BULGE
;; Returns the proportinal bulge to the référence bulge
;; Arguments :
;; b : the bulge
;; k : the proportion ratio (between angles or arcs length)
(defun k*bulge (b k / a)
(setq a (atan b))
(/ (sin (* k a)) (cos (* k a)))
);; EL2PL
;; Converts ellipses and elliptcal arcs into polylines(defun c:el2pl (/ *error* fra acdoc ss)
(vl-load-com)
(defun *error* (msg)
(if (and (/= msg "Fonction annulée")
(/= msg "Function cancelled")
)
(princ (strcat (if (= "FRA" (getvar 'locale))
"\nErreur: "
"\Error: "
)
msg
)
)
)
(vla-endUndoMark acdoc)
(princ)
)
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)))
(if (ssget '((0 . "ELLIPSE")))
(progn (vla-StartUndoMark acdoc)
(vlax-for e (setq ss (vla-get-ActiveSelectionSet acdoc))
(EllipseToPolyline e)
(vla-delete e)
)
(vla-delete ss)
(vla-EndUndoMark acdoc)
)
)
(princ)
);; PELL
;; Draws an ellipse or an elliptical arc approximation (polyline) on the fly
(defun c:pell (/ *error* ec pe old ent)
(vl-load-com)
(defun *error* (msg)
(if (and msg
(/= msg "Fonction annulée")
(/= msg "Function cancelled")
)
(princ (strcat (if (= "FRA" (getvar 'locale))
"\nErreur: "
"\Error: "
)
msg
)
)
)
(setvar 'cmdecho ec)
(setvar 'pellipse pe)
(princ)
)
(setq ec(getvar 'cmdecho)
pe(getvar 'pellipse)
old (entlast)
)
(setvar 'cmdecho 1)
(setvar 'pellipse 0)
(command "_.ellipse")
(while (/= 0 (getvar 'cmdactive)) (command pause))
(if (not (eq old (setq ent (entlast))))
(progn (EllipseToPolyline (vlax-ename->vla-object ent))
(entdel ent)
)
)
(*error* nil)
)
经过实测,还是有点差别的 本帖最后由 尘缘一生 于 2021-12-23 20:30 编辑
tigcat 发表于 2021-12-23 19:37
经过实测,还是有点差别的
这是我在网上看到的源程序，这个程序，可以解决问题，本坛缺少这个。这个支持椭圆、椭圆弧。改写后我暂时采用。
[*];; 椭圆（弧）转多段线（非直线模拟）----（一级）---------------
[*](defun arc->pline (enam / cl norm cen elv pt0 pt1 pt2 pt3 pt4 ac0 ac4 a04 a02 a24 bsc0 bsc2 bsc3 bsc4 plst
[*] blst spt spa fspa srat ept epa fepa erat n obj
[*] )
[*];; 角度正切值-----（一级）-------
[*](defun tan (a) (/ (sin a) (cos a)))
[*];; b : the bulge
[*];; k : the proportion ratio (between angles or arcs length)
[*](defun k*bulge (b k / a)
[*] (setq a (atan b))
[*] (/ (sin (* k a)) (cos (* k a)))
[*])
[*];; lst : a list
[*];; start : start index (first item = 0)
[*];; leng : the sub list length (number of items) or nil
[*](defun sublist (lst start leng / n r)
[*] (if (or (not leng) (< (- (length lst) start) leng))
[*] (setq leng (- (length lst) start))
[*] )
[*] (setq n (+ start leng))
[*] (while (< start n)
[*] (setq r (cons (nth (setq n (1- n)) lst) r))
[*] )
[*])
[*];;-------------------------
[*](if (= (type enam) 'ENAME) (setq obj (en2obj enam)))
[*](setq cl (= (Angle-Mod (vla-get-StartAngle obj)) (Angle-Mod (vla-get-EndAngle obj)))
[*] norm (vlax-get obj 'Normal)
[*] cen(trans (vlax-get obj 'Center) 0 norm)
[*] elv(caddr cen)
[*] cen(3dTo2dPt cen)
[*] pt0(mapcar '+ (trans (vlax-get obj 'MajorAxis) 0 norm) cen)
[*] ac0(angle cen pt0)
[*] pt4(mapcar '+ cen (trans (vlax-get obj 'MinorAxis) 0 norm))
[*] pt2(3dTo2dPt (trans (vlax-curve-getPointAtparam obj pi4) 0 norm))
[*] ac4(angle cen pt4)
[*] a04(angle pt0 pt4)
[*] a02(angle pt0 pt2)
[*] a24(angle pt2 pt4)
[*] bsc0 (* (Angle-Mod (- a02 ac4)) 0.5)
[*] bsc2 (* (Angle-Mod (- a04 a02)) 0.5)
[*] bsc3 (* (Angle-Mod (- a24 a04)) 0.5)
[*] bsc4 (* (Angle-Mod (- (+ ac0 pi) a24)) 0.5)
[*] pt1(inters pt0
[*] (polar pt0 (+ ac0 pi2 bsc0) 1.)
[*] pt2
[*] (polar pt2 (+ a02 bsc2) 1.)
[*] nil
[*] )
[*] pt3(inters pt2
[*] (polar pt2 (+ a04 bsc3) 1.)
[*] pt4
[*] (polar pt4 (+ a24 bsc4) 1.)
[*] nil
[*] )
[*] plst (list pt4 pt3 pt2 pt1 pt0)
[*] blst (mapcar '(lambda (b) (tan (* b 0.5))) (list bsc4 bsc3 bsc2 bsc0))
[*])
[*](foreach b blst (setq blst (cons b blst)))
[*](foreach b blst (setq blst (cons b blst)))
[*](foreach p (cdr plst)
[*] (setq ang (angle cen p)
[*] plst (cons (polar cen (+ ang (* 2 (- ac4 ang))) (distance cen p)) plst)
[*] )
[*])
[*](foreach p (cdr plst)
[*] (setq ang (angle cen p)
[*] plst (cons (polar cen (+ ang (* 2 (- ac0 ang))) (distance cen p)) plst)
[*] )
[*])
[*](setq pl (vlax-invoke
[*] (vla-get-ModelSpace (vla-get-ActiveDocument (vlax-get-acad-object)))
[*] 'AddLightWeightPolyline
[*] (apply 'append (setq plst (reverse (if cl (cdr plst) plst))))
[*] )
[*])
[*](vlax-put pl 'Normal norm)
[*](vla-put-Elevation pl elv)
[*](mapcar '(lambda (i v) (vla-SetBulge pl i v)) '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16) blst)
[*](if cl
[*] (vla-put-Closed pl :vlax-true)
[*] (progn
[*] (setq spt (vlax-curve-getClosestPointTo pl (vlax-get obj 'Startpoint))
[*] spa(vlax-curve-getParamAtPoint pl spt)
[*] fspa (fix spa)
[*] ept(vlax-curve-getClosestPointTo pl (vlax-get obj 'Endpoint))
[*] epa(vlax-curve-getParamAtPoint pl ept)
[*] fepa (fix epa)
[*] n 0
[*] )
[*] (cond
[*] ((equal spt (trans pt0 norm 0) 1e-9)
[*] (if (= epa fepa)
[*] (setq plst (sublist plst 0 (1+ fepa)) blst (sublist blst 0 (1+ fepa)))
[*] (setq erat (/ (- (vlax-curve-getDistAtParam pl epa) (vlax-curve-getDistAtParam pl fepa))
[*] (- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17)) (vlax-curve-getDistAtParam pl fepa))
[*] )
[*] plst (append (sublist plst 0 (1+ fepa)) (list (3dTo2dPt (trans ept 0 norm))))
[*] blst (append (sublist blst 0 (1+ fepa)) (list (k*bulge (nth fepa blst) erat)))
[*] )
[*] )
[*] )
[*] ((equal ept (trans pt0 norm 0) 1e-9)
[*] (if (= spa fspa)
[*] (setq plst (sublist plst fspa nil)
[*] blst (sublist blst fspa nil)
[*] )
[*] (setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
[*] (vlax-curve-getDistAtParam pl spa)
[*] )
[*] (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17))
[*] (vlax-curve-getDistAtParam pl fspa)
[*] )
[*] )
[*] plst (cons (3dTo2dPt (trans spt 0 norm)) (sublist plst (1+ fspa) nil))
[*] blst (cons (k*bulge (nth fspa blst) srat) (sublist blst (1+ fspa) nil))
[*] )
[*] )
[*] )
[*] (T
[*] (setq srat (/ (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17)) (vlax-curve-getDistAtParam pl spa))
[*] (- (vlax-curve-getDistAtParam pl (rem (1+ fspa) 17)) (vlax-curve-getDistAtParam pl fspa))
[*] )
[*] erat (/ (- (vlax-curve-getDistAtParam pl epa) (vlax-curve-getDistAtParam pl fepa))
[*] (- (vlax-curve-getDistAtParam pl (rem (1+ fepa) 17)) (vlax-curve-getDistAtParam pl fepa))
[*] )
[*] )
[*] (if (< epa spa)
[*] (setq plst (append (if (= spa fspa)
[*] (sublist plst fspa nil)
[*] (cons (3dTo2dPt (trans spt 0 norm)) (sublist plst (1+ fspa) nil))
[*] )
[*] (cdr (sublist plst 0 (1+ fepa)))
[*] (if (/= epa fepa)
[*] (list (3dTo2dPt (trans ept 0 norm)))
[*] )
[*] )
[*] blst (append (if (= spa fspa)
[*] (sublist blst fspa nil)
[*] (cons (k*bulge (nth fspa blst) srat) (sublist blst (1+ fspa) nil))
[*] )
[*] (sublist blst 0 fepa)
[*] (if (= epa fepa)
[*] (list (nth fepa blst))
[*] (list (k*bulge (nth fepa blst) erat))
[*] )
[*] )
[*] )
[*] (setq plst (append (if (= spa fspa)
[*] (sublist plst fspa (1+ (- fepa fspa)))
[*] (cons (3dTo2dPt (trans spt 0 norm)) (sublist plst (1+ fspa) (- fepa fspa)))
[*] )
[*] (list (3dTo2dPt (trans ept 0 norm)))
[*] )
[*] blst (append (if (= spa fspa)
[*] (sublist blst fspa (- fepa fspa))
[*] (cons (k*bulge (nth fspa blst) srat) (sublist blst (1+ fspa) (- fepa fspa)))
[*] )
[*] (if (= epa fepa)
[*] (list (nth fepa blst))
[*] (list (k*bulge (nth fepa blst) erat))
[*] )
[*] )
[*] )
[*] )
[*] )
[*] )
[*] (vlax-put pl 'Coordinates (apply 'append plst))
[*] (foreach b blst (vla-SetBulge pl n b) (setq n (1+ n)))
[*] )
[*])
[*](sl:-erase obj)
[*]pl
[*])
页:
[1]