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

vbnewer

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

xinrstar

(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

ET带有一个 非常不错 flatten

vbnewer

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

vbnewer

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

lucas_3333

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

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

vbnewer

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

vbnewer

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

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

LYC688

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

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