一键转椭圆

wjlddh

大师帮忙些个一键椭圆的LSP  文件是有其它软件倒进CAD的  本身是椭圆  CAD打开是多段线的  搜了下论坛帖子 很少关于椭圆插件的问题  有大师抽时间琢磨一下 万分感谢

wjlddh

没人知道么

Andyhon

(defun mid_pt (a b)
   (mapcar
     (function (lambda (a b) (/ (+ a b) 2)))
     a
     b
   )
)

(defun C:try ()
   (setq ss (ssget "X" '((0 . "LWPOLYLINE")))
        2Pi (* Pi 2)
          i  -1
   )
   (while (setq ee (ssname ss (setq i (1+ i))))
     (setq pts (reverse (acet-ent-geomextents ee))
           pt5 (apply 'mid_pt pts)
            xx (apply '- (mapcar 'car pts))
            yy (apply '- (mapcar 'cadr pts))
     )        
     (entmake
      (list
        '(0 . "ELLIPSE")
        '(100 . "AcDbEntity")
        '(100 . "AcDbEllipse")
        (cons 10 pt5)
        (list 11 (/ xx 2) 0.0 0.0)
        (cons 40 (/ yy xx))
        '(41 . 0.0)
        (cons 42 2Pi)
     ))
   )
   (command "erase" ss "")
   (princ)
)

存在着精度差
CAD得安装有 EXPRESS TOOLS

wjlddh

好像椭圆都存在一定的难度啊

ssyfeng

试试这个，不用安装EXPRESS TOOLS
(defun c:tt (/ a b en maxpt midpt minpt obj pt2 pt4 ss ssn)
  (setq ss (ssget)
  ssn (sslength ss)
)
(repeat ssn
  (setq en (ssname ss (setq ssn (1- ssn)))
   obj (vlax-ename->vla-object en)
  )
  (vla-GetBoundingBox obj 'minPt 'maxPt)
  (setq minPt (vlax-safearray->list minPt))
  (setq maxPt (vlax-safearray->list maxPt))
  (setq midpt (mapcar '(lambda (a b) (* (+ a b) 0.5)) minPt maxPt)
   pt2 (list (car maxPt) (cadr minPt))
   pt4 (list (car minPt) (cadr maxPt))
   a (* (distance minpt pt2) 0.5)
   b (* (distance minpt pt4) 0.5)
  )
  (entmake
   (list
    '(0 . "ELLIPSE")
    '(100 . "AcDbEntity")
    '(100 . "AcDbEllipse")
    (cons 10 midpt)
    (list 11 a 0.0 0.0)
    (cons 40 (/ b a))
    '(41 . 0.0)
    (cons 42 (* 2 pi))
   )
  )
)
(vl-cmdf "erase" ss "")
(princ)
)

wjlddh

感谢 ssyfeng  这个非常好用