CAD椭圆(弧)转多段线(非模拟)插件源码分享

云墨 2022年4月3日19:14:26工具插件评论3515564字阅读18分32秒阅读模式
椭圆(弧)转换为多段线弧(非模拟)
;; 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    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
                         )
  (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)
)

1. 如有链接无法下载、失效或广告,请联系QQ:3392178029 处理!
2. 本站的所有资源为购买、网络收集,或者用户投稿的资源,版权归原作者及网站所有!
3. 如若侵犯了您的权利,请及时联系站长删除!
4. 本站提供的资源,都不包含技术服务请大家谅解!
5. 此软件“仅限学习交流,不能用于商业用途”!
6. 如用于商业用途,请到官方购买正版软件,追究法律责任与“猿沐软件网”无关!
  • 老师个人微信
  • 微信扫一扫
  • weinxin
  • 设计课堂公众号
  • 微信扫一扫
  • weinxin
云墨
  • 本文由 发表于 2022年4月3日19:14:26
  • 转载请务必保留本文链接:https://www.yuanmoo.net/7593.html【猿沐软件网】
匿名

发表评论

匿名网友 填写信息

:?: :razz: :sad: :evil: :!: :smile: :oops: :grin: :eek: :shock: :???: :cool: :lol: :mad: :twisted: :roll: :wink: :idea: :arrow: :neutral: :cry: :mrgreen: