wjlddh 发表于 2018-9-9 16:45:50

一键转椭圆

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

wjlddh 发表于 2018-9-10 09:58:33

没人知道么

Andyhon 发表于 2018-9-10 12:19:42

(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 发表于 2018-9-10 13:28:50

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

ssyfeng 发表于 2018-9-10 14:56:19

试试这个，不用安装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 发表于 2018-9-11 15:07:44

感谢 ssyfeng这个非常好用
页: [1]
查看完整版本: 一键转椭圆