求一个圆变正方形的功能

664571221

我这里有一个直径为1000的圆形，求输入命令tt，点击圆形变成边长为1000的正方形，中心相同

xinrstar

1. (defun c:tt (/ ss i cen rad a ent ename)
   
2.   (if (setq ss (ssget '((0 . "circle"))))
   
3.     (repeat (setq i (sslength ss))
   
4.       (setq ename (ssname ss (setq i (1- i)))
   
5.             ent   (entget ename)
   
6.             cen   (cdr (assoc 10 ent))
   
7.             rad   (cdr (assoc 40 ent))
   
8.             a     (* rad (sqrt 2.0))
   
9.       )
   
10.       ;;(entdel ename)
    
11.       (entmake (append (list '(0 . "LWPOLYLINE")
    
12.                              '(100 . "AcDbEntity")
    
13.                              '(100 . "AcDbPolyline")
    
14.                              (assoc 8 ent)
    
15.                              '(90 . 4)
    
16.                              '(70 . 1)
    
17.                        )
    
18.                        (mapcar (function (lambda (pt) (cons 10 pt)))
    
19.                                (mapcar (function (lambda (x) (polar cen x a )))
    
20.                                        (list (* pi 0.25) (* pi 0.75) (* pi 1.25) (* pi 1.75))
    
21.                                )
    
22.                        )
    
23.                )
    
24.       )      
    
25.     )
    
26.   )
    
27. )

(defun c:tt (/ ss i cen rad a ent ename)<br />   (if (setq ss (ssget '((0 . "circle"))))<br />     (repeat (setq i (sslength ss))<br />       (setq ename (ssname ss (setq i (1- i)))<br />             ent   (entget ename)<br />             cen   (cdr (assoc 10 ent))<br />             rad   (cdr (assoc 40 ent))<br />             a     (* rad (sqrt 2.0))<br />       )<br />       ;;(entdel ename)<br />       (entmake (append (list '(0 . "LWPOLYLINE")<br />                              '(100 . "AcDbEntity")<br />                              '(100 . "AcDbPolyline")<br />                              (assoc 8 ent)<br />                              '(90 . 4)<br />                              '(70 . 1)<br />                        )<br />                        (mapcar (function (lambda (pt) (cons 10 pt)))<br />                                (mapcar (function (lambda (x) (polar cen x a )))<br />                                        (list (* pi 0.25) (* pi 0.75) (* pi 1.25) (* pi 1.75))<br />                                )<br />                        )<br />                )<br />       )      <br />     )<br />   )<br /> )

ThinkerHua

2. (defun c:tt (/ engs_circle centerofcircle lengthofside p1 p2 p3 p4)
   
3.   (setq engs_circle (entget (car (entsel "\n请选择需转换的圆："))))
   
4.   (setq centerofcircle (cdr (assoc 10 engs_circle)))
   
5.   (setq lengthofside (cdr (assoc 40 engs_circle)))
   
6.   (setq        p1 (polar centerofcircle
   
7.                   (* pi 0.75)
   
8.                   (/ lengthofside (sin (* pi 0.25)))
   
9.            )
   
10.   )
    
11.   (setq        p2 (polar centerofcircle
    
12.                   (* pi 0.25)
    
13.                   (/ lengthofside (sin (* pi 0.25)))
    
14.            )
    
15.   )
    
16.   (setq        p3 (polar centerofcircle
    
17.                   (* pi 1.75)
    
18.                   (/ lengthofside (sin (* pi 0.25)))
    
19.            )
    
20.   )
    
21.   (setq        p4 (polar centerofcircle
    
22.                   (* pi 1.25)
    
23.                   (/ lengthofside (sin (* pi 0.25)))
    
24.            )
    
25.   )
    
26.   (entmake (list '(0 . "LWPOLYLINE")
    
27.                  '(100 . "AcDbEntity")
    
28.                  '(100 . "AcDbPolyline")
    
29.                  (cons 90 4)
    
30.                  (cons 70 1)
    
31.                  (cons 10 p1)
    
32.                  (cons 10 p2)
    
33.                  (cons 10 p3)
    
34.                  (cons 10 p4)
    
35.            )
    
36.   )
    
37.   (entdel (cdr (car engs_circle)))
    
38.   (prin1)
    
39. )

(defun c:tt (/ engs_circle centerofcircle lengthofside p1 p2 p3 p4)<br />   (setq engs_circle (entget (car (entsel "\n请选择需转换的圆："))))<br />   (setq centerofcircle (cdr (assoc 10 engs_circle)))<br />   (setq lengthofside (cdr (assoc 40 engs_circle)))<br />   (setq        p1 (polar centerofcircle<br />                   (* pi 0.75)<br />                   (/ lengthofside (sin (* pi 0.25)))<br />            )<br />   )<br />   (setq        p2 (polar centerofcircle<br />                   (* pi 0.25)<br />                   (/ lengthofside (sin (* pi 0.25)))<br />            )<br />   )<br />   (setq        p3 (polar centerofcircle<br />                   (* pi 1.75)<br />                   (/ lengthofside (sin (* pi 0.25)))<br />            )<br />   )<br />   (setq        p4 (polar centerofcircle<br />                   (* pi 1.25)<br />                   (/ lengthofside (sin (* pi 0.25)))<br />            )<br />   )<br />   (entmake (list '(0 . "LWPOLYLINE")<br />                  '(100 . "AcDbEntity")<br />                  '(100 . "AcDbPolyline")<br />                  (cons 90 4)<br />                  (cons 70 1)<br />                  (cons 10 p1)<br />                  (cons 10 p2)<br />                  (cons 10 p3)<br />                  (cons 10 p4)<br />            )<br />   )<br />   (entdel (cdr (car engs_circle)))<br />   (prin1)<br /> )

ZZXXQQ

2. (defun c:tt (/ ss i ent)
   
3.   (setvar "CMDECHO" 0)
   
4.   (command ".UNDO" "BE")
   
5.   (if (setq ss (ssget '((0 . "CIRCLE")))) (progn
   
6.     (repeat (setq i (sslength ss))
   
7.       (setq ent (entget (ssname ss (setq i (1- i)))))
   
8.       (command "_.POLYGON" "4" (cdr (assoc 10 ent)) "C" (cdr (assoc 40 ent)))
   
9.     )
   
10.     (command "_.ERASE" ss "")
    
11.   ))
    
12.   (command ".UNDO" "E")
    
13.   (setvar "CMDECHO" 1)
    
14.   (princ)
    
15. )
    

(defun c:tt (/ ss i ent)<br />   (setvar "CMDECHO" 0)<br />   (command ".UNDO" "BE")<br />   (if (setq ss (ssget '((0 . "CIRCLE")))) (progn<br />     (repeat (setq i (sslength ss))<br />       (setq ent (entget (ssname ss (setq i (1- i)))))<br />       (command "_.POLYGON" "4" (cdr (assoc 10 ent)) "C" (cdr (assoc 40 ent)))<br />     )<br />     (command "_.ERASE" ss "")<br />   ))<br />   (command ".UNDO" "E")<br />   (setvar "CMDECHO" 1)<br />   (princ)<br /> )<br />

shh1980

ZZXXQQ 发表于 2016-3-7 10:32

简明扼要，我最喜欢这种分格了！
向大师致敬！

xyp1964

2. (defun c:tt (/ ss i s1 p0 rr p1 p2)
   
3.   (if (setq ss (ssget '((0 . "circle"))))
   
4.     (progn
   
5.       (setq i -1)
   
6.       (while (setq s1 (ssname ss (setq i (1+ i))))
   
7.         (setq p0 (cdr (assoc 10 (entget s1)))
   
8.               rr (cdr (assoc 40 (entget s1)))
   
9.               p1 (list (- (car p0) rr) (- (cadr p0) rr))
   
10.               p2 (list (+ (car p0) rr) (+ (cadr p0) rr))
    
11.         )
    
12.         (command "rectang" "non" p1 "non" p2)
    
13.       )
    
14.       (command "erase" ss "")
    
15.     )
    
16.   )
    
17.   (princ)
    
18. )

(defun c:tt (/ ss i s1 p0 rr p1 p2)<br />   (if (setq ss (ssget '((0 . "circle"))))<br />     (progn<br />       (setq i -1)<br />       (while (setq s1 (ssname ss (setq i (1+ i))))<br />         (setq p0 (cdr (assoc 10 (entget s1)))<br />               rr (cdr (assoc 40 (entget s1)))<br />               p1 (list (- (car p0) rr) (- (cadr p0) rr))<br />               p2 (list (+ (car p0) rr) (+ (cadr p0) rr))<br />         )<br />         (command "rectang" "non" p1 "non" p2)<br />       )<br />       (command "erase" ss "")<br />     )<br />   )<br />   (princ)<br /> )

437271963

VBA函数提取的坐标比较准确，法向坐标-1的也可以准确提取。

2. (defun c:tes ( / &k1 &kw1 &ss1 pt1 pt2 pt3 pt4 tc1 x)
   
3. (if (null vlax-dump-object) (vl-load-com) )
   
4. (if (setq &kw1 (ssget '((0 . "CIRCLE"))));选择圆
   
5.   (progn
   
6.    (while (setq &k1 (ssname &kw1 0))
   
7.     (setq &kw1 (ssdel &k1 &kw1))
   
8.     (setq &k1 (vlax-ename->vla-object &k1));变VLA对象
   
9.     (vla-GetBoundingBox &k1 'pt1 'pt2);计算包围盒
   
10.     (setq tc1 (vla-get-layer &k1));得到图层
    
11.     (vla-delete &k1);删除圆
    
12.     (setq &ss1
    
13.      (mapcar '(lambda (x) (list (car x) (cadr x)))
    
14.      (mapcar 'vlax-safearray->list (list pt1 pt2))
    
15.     );取得坐标
    
16.     (setq pt1 (car &ss1)
    
17.           pt3 (cadr &ss1)
    
18.           pt2 (list (car pt1) (cadr pt3))
    
19.           pt4 (list (car pt3) (cadr pt1)))
    
20.           &ss1 (list pt1 pt2 pt3 pt4)
    
21.     );计算得到4点坐标
    
22.     (entmake
    
23.      (append
    
24.       (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 tc1) '(90 . 4) '(70 . 1) '(38 . 0))
    
25.       (mapcar '(lambda (x) (cons 10 x)) &ss1)
    
26.       );矩形的图层与圆相同，Z标高是0
    
27.     );利用entmake函数绘制图形是最快的，不受捕捉影响
    
28.    )
    
29.   )
    
30. )
    
31. (princ)
    
32. )

(defun c:tes ( / &k1 &kw1 &ss1 pt1 pt2 pt3 pt4 tc1 x)<br /> (if (null vlax-dump-object) (vl-load-com) )<br /> (if (setq &kw1 (ssget '((0 . "CIRCLE"))));选择圆<br />   (progn<br />    (while (setq &k1 (ssname &kw1 0))<br />     (setq &kw1 (ssdel &k1 &kw1))<br />     (setq &k1 (vlax-ename->vla-object &k1));变VLA对象<br />     (vla-GetBoundingBox &k1 'pt1 'pt2);计算包围盒<br />     (setq tc1 (vla-get-layer &k1));得到图层<br />     (vla-delete &k1);删除圆<br />     (setq &ss1<br />      (mapcar '(lambda (x) (list (car x) (cadr x)))<br />      (mapcar 'vlax-safearray->list (list pt1 pt2))<br />     );取得坐标<br />     (setq pt1 (car &ss1)<br />           pt3 (cadr &ss1)<br />           pt2 (list (car pt1) (cadr pt3))<br />           pt4 (list (car pt3) (cadr pt1)))<br />           &ss1 (list pt1 pt2 pt3 pt4)<br />     );计算得到4点坐标<br />     (entmake<br />      (append<br />       (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 tc1) '(90 . 4) '(70 . 1) '(38 . 0))<br />       (mapcar '(lambda (x) (cons 10 x)) &ss1)<br />       );矩形的图层与圆相同，Z标高是0<br />     );利用entmake函数绘制图形是最快的，不受捕捉影响<br />    )<br />   )<br /> )<br /> (princ)<br /> )

ysq101

ZZXXQQ 发表于 2016-3-7 10:32

用到COMMAND   给个差评
开个玩笑，Z大能力可是大大的
我也只能用COMMAND来写一些小程序

feng83

ysq101 发表于 2016-3-14 13:02
用到COMMAND   给个差评
开个玩笑，Z大能力可是大大的
我也只能用COMMAND来写一些小程序

人家化繁为简