求一个圆变正方形的功能
我这里有一个直径为1000的圆形，求输入命令tt，点击圆形变成边长为1000的正方形，中心相同(defun c:tt (/ ss i cen rad a ent ename)
(if (setq ss (ssget '((0 . "circle"))))
(repeat (setq i (sslength ss))
(setq ename (ssname ss (setq i (1- i)))
ent (entget ename)
cen (cdr (assoc 10 ent))
rad (cdr (assoc 40 ent))
a (* rad (sqrt 2.0))
)
;;(entdel ename)
(entmake (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(assoc 8 ent)
'(90 . 4)
'(70 . 1)
)
(mapcar (function (lambda (pt) (cons 10 pt)))
(mapcar (function (lambda (x) (polar cen x a )))
(list (* pi 0.25) (* pi 0.75) (* pi 1.25) (* pi 1.75))
)
)
)
)
)
)
)
本帖最后由 ThinkerHua 于 2016-3-6 11:57 编辑
(defun c:tt (/ engs_circle centerofcircle lengthofside p1 p2 p3 p4)
(setq engs_circle (entget (car (entsel "\n请选择需转换的圆："))))
(setq centerofcircle (cdr (assoc 10 engs_circle)))
(setq lengthofside (cdr (assoc 40 engs_circle)))
(setq p1 (polar centerofcircle
(* pi 0.75)
(/ lengthofside (sin (* pi 0.25)))
)
)
(setq p2 (polar centerofcircle
(* pi 0.25)
(/ lengthofside (sin (* pi 0.25)))
)
)
(setq p3 (polar centerofcircle
(* pi 1.75)
(/ lengthofside (sin (* pi 0.25)))
)
)
(setq p4 (polar centerofcircle
(* pi 1.25)
(/ lengthofside (sin (* pi 0.25)))
)
)
(entmake (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 4)
(cons 70 1)
(cons 10 p1)
(cons 10 p2)
(cons 10 p3)
(cons 10 p4)
)
)
(entdel (cdr (car engs_circle)))
(prin1)
) (defun c:tt (/ ss i ent)
(setvar "CMDECHO" 0)
(command ".UNDO" "BE")
(if (setq ss (ssget '((0 . "CIRCLE")))) (progn
(repeat (setq i (sslength ss))
(setq ent (entget (ssname ss (setq i (1- i)))))
(command "_.POLYGON" "4" (cdr (assoc 10 ent)) "C" (cdr (assoc 40 ent)))
)
(command "_.ERASE" ss "")
))
(command ".UNDO" "E")
(setvar "CMDECHO" 1)
(princ)
)
ZZXXQQ 发表于 2016-3-7 10:32 static/image/common/back.gif
简明扼要，我最喜欢这种分格了！
向大师致敬！ (defun c:tt (/ ss i s1 p0 rr p1 p2)
(if (setq ss (ssget '((0 . "circle"))))
(progn
(setq i -1)
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq p0 (cdr (assoc 10 (entget s1)))
rr (cdr (assoc 40 (entget s1)))
p1 (list (- (car p0) rr) (- (cadr p0) rr))
p2 (list (+ (car p0) rr) (+ (cadr p0) rr))
)
(command "rectang" "non" p1 "non" p2)
)
(command "erase" ss "")
)
)
(princ)
) 本帖最后由 437271963 于 2016-3-13 09:53 编辑
VBA函数提取的坐标比较准确，法向坐标-1的也可以准确提取。(defun c:tes ( / &k1 &kw1 &ss1 pt1 pt2 pt3 pt4 tc1 x)
(if (null vlax-dump-object) (vl-load-com) )
(if (setq &kw1 (ssget '((0 . "CIRCLE"))));选择圆
(progn
(while (setq &k1 (ssname &kw1 0))
(setq &kw1 (ssdel &k1 &kw1))
(setq &k1 (vlax-ename->vla-object &k1));变VLA对象
(vla-GetBoundingBox &k1 'pt1 'pt2);计算包围盒
(setq tc1 (vla-get-layer &k1));得到图层
(vla-delete &k1);删除圆
(setq &ss1
(mapcar '(lambda (x) (list (car x) (cadr x)))
(mapcar 'vlax-safearray->list (list pt1 pt2))
);取得坐标
(setq pt1 (car &ss1)
pt3 (cadr &ss1)
pt2 (list (car pt1) (cadr pt3))
pt4 (list (car pt3) (cadr pt1)))
&ss1 (list pt1 pt2 pt3 pt4)
);计算得到4点坐标
(entmake
(append
(list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 8 tc1) '(90 . 4) '(70 . 1) '(38 . 0))
(mapcar '(lambda (x) (cons 10 x)) &ss1)
);矩形的图层与圆相同，Z标高是0
);利用entmake函数绘制图形是最快的，不受捕捉影响
)
)
)
(princ)
) ZZXXQQ 发表于 2016-3-7 10:32 static/image/common/back.gif
用到COMMAND 给个差评
开个玩笑，Z大能力可是大大的
我也只能用COMMAND来写一些小程序 ysq101 发表于 2016-3-14 13:02 static/image/common/back.gif
用到COMMAND 给个差评
开个玩笑，Z大能力可是大大的
我也只能用COMMAND来写一些小程序
人家化繁为简
页:
[1]