社区 › AutoLISP/Visual LISP 编程技术 › 求样条曲线、椭圆转圆弧源码

vbnewer 发表于 2015-4-2 23:44:44

求样条曲线、椭圆转圆弧源码

求样条曲线、椭圆转圆弧源码。
不是要转多段线的。
燕秀工具箱有这个功能，但是软件太庞大了，多出来一堆工具栏，想用个轻量级的 。

xinrstar 发表于 2015-4-2 23:44:45

(defun c:sp2arc        (/ ename ent i j ss n)
(defun make-arc (p1 p2 p3 / ang1 ang2 cen pt1 pt2 pt3 pt4 rad ename)
    (setq ang1 (angle p1 p2)
          ang2 (angle p2 p3)
          pt1(polar p1 ang1 (/ (distance p1 p2) 2))
          pt2(polar p2 ang2 (/ (distance p2 p3) 2))
          pt3(polar pt1 (+ ang1 (/ pi 2)) 1)
          pt4(polar pt2 (+ ang2 (/ pi 2)) 1)
          cen(inters pt1 pt3 pt2 pt4 nil)
          rad(distance cen p1)
          ang1 (angle cen p1)
          ang2 (angle cen p3)
    )
    (entmake (list '(0 . "arc")
                   (cons 10 cen)
                   (cons 40 rad)
                   (cons 50 ang1)
                   (cons 51 ang2)
             )
    )
    (setq ename (entlast))
    (if        (> (vla-get-arclength (vlax-ename->vla-object ename))
           (* pi rad)
        )
      (progn (entdel ename)
             (entmake (list '(0 . "arc")
                          (cons 10 cen)
                          (cons 40 rad)
                          (cons 50 ang2)
                          (cons 51 ang1)
                      )
             )
      )
    )
)
;;FUNCATION SPARC
(defun sparc
       (ename / a arcss b i idlst j k len new p1 p2 p3 per vlaobj)
    (vl-load-com)
    (setq vlaobj (vlax-ename->vla-object ename))
    (if        (< (setq per (vlax-curve-getdistatpoint
                     vlaobj
                     (vlax-curve-getendpoint vlaobj)
                     )
           )
           1.0
        )
      (setq a (/ per 10))
      (if (>= per 500)
        (setq a (/ per 2000))
        (setq a (/ per (+ (* (fix (/ (/ per 0.25) 4)) 4) 2)))
      )
    )
    (setq idlst        nil
          i 0
          b 0
    )
    (while (< b per)
      (setq b          (* a i)
          i          (1+ i)
          idlst (append idlst (list (vlax-curve-getpointatdist vlaobj b)))
      )
    )
    (entdel (vlax-vla-object->ename vlaobj))
    (setq i        0
          j        1
          k        2
          len        (length idlst)
          arcss        (ssadd)
    )
    (while (<= k len)
      (setq p1 (nth i idlst)
          p2 (nth j idlst)
          p3 (nth k idlst)
      )
      (setq i (+ i 2)
          j (+ j 2)
          k (+ k 2)
      )
      (make-arc p1 p2 p3)
      (setq new (entlast))
      (setq arcss (ssadd new arcss))
    )
    (command "pedit" new "y" "j" arcss "" "")
)
;;FUNCATION GET_COLOR
(defun get_color (ename / ent col)
    (setq ent (entget ename))
    (or        (setq col (cdr (assoc 62 ent)))
        (setq
          col (cdr (assoc 62 (tblsearch "layer" (cdr (assoc 8 ent)))))
        )
    )
    (rtos col 2 0)
)
;;MAIN
(if (setq ss (ssget '((0 . "SPLINE"))))
    (progn
      (setq i 0
          n (sslength ss)
      )
      (repeat n
        (setq ename (ssname ss i)
              ent   (entget ename)
        )
        (setvar "clayer" (cdr (assoc 8 ent)))
        (setvar "cecolor" (get_color ename))
        (sparc ename)
        (setq i (1+ i))
      )
      (alert (strcat "\n共 " (rtos n 2 0) " 条SPLINE转换成ARC"))
    )
)
(princ)
)

xiaotao 发表于 2015-4-3 00:43:56

ET带有一个 非常不错 flatten

vbnewer 发表于 2015-4-3 08:48:50

flatten转出来是折线，不是圆弧吧？

vbnewer 发表于 2015-4-3 21:33:35

楼上的程序虽然不是很完美，椭圆弧不能转，但已经非常强大了，谢谢。
小白没币，1个明经币只是意思一下而已，大家肯定都不看在眼里，谢谢大家，期待更加完美的程序。

lucas_3333 发表于 2015-4-3 23:04:03

vbnewer 发表于 2015-4-3 21:33 static/image/common/back.gif
楼上的程序虽然不是很完美，椭圆弧不能转，但已经非常强大了，谢谢。
小白没币，1个明经币只是意思一下而已 ...

你想多啦， 椭圆弧如何转圆弧 ？ 只有长轴与短轴相等的情况下才能转

vbnewer 发表于 2015-4-3 23:15:48

本帖最后由 vbnewer 于 2015-4-3 23:17 编辑

椭圆转圆弧当然是近似转换，包括样条曲线也是近似转换，分段数越多越接近原弧线。

vbnewer 发表于 2015-12-19 16:52:52

xinrstar 发表于 2015-4-3 20:49 static/image/common/back.gif
(defun c:sp2arc        (/ ename ent i j ss n)
(defun make-arc (p1 p2 p3 / ang1 ang2 cen pt1 pt2 pt3 pt4...

请问如何更改分段长度？谢谢。

LYC688 发表于 2023-8-16 03:15:10

xiaotao 发表于 2015-4-3 00:43
ET带有一个 非常不错 flatten

这个功能不行。转出来，有些地方公差0.01mm

查看完整版本: 求样条曲线、椭圆转圆弧源码