[分享]动态圆弧拖拉并显示圆弧半径
我参考晓东CAD里的一个动态直线拖拉显直线长度程序，改成了动态圆弧拖拉并显示圆弧半径，这一功能不一定经常会用到，但也值得参考。(defun c:ad ()<BR> (setvar "CMDECHO" 0)<BR> (setvar "osmode" 0)<BR> (setq pt1 (getpoint "\n请输入圆弧起点: "))<BR> (setq pt3 (getpoint "\n请输入圆弧第二点: "))<BR> (setq pt2 (cadr (grread T 4 0)))<BR> (setq pt2 (mapcar '+ pt2 '(0.0001 -0.0001)))<BR> (command "Arc" pt1 pt3 pt2)
(setq ent (entlast))<BR> (setq arc0 (entget ent))<BR> (setq r0 (rtos (cdr (assoc 40 arc0))))<BR> ;;求圆弧新的半径值并转化为字符型<BR> (setq ts1 "R=")<BR> (setq ts2 (strcat ts1 r0 "mm"))<BR> (command "text" pt2 "2.5" "" ts2)<BR> (setq tx1 (entlast))<BR> (vla-put-color (vlax-ename->vla-object tx1) 1)<BR> (setq tx2 (entget tx1))<BR> (setq pick nil)<BR> (while (not pick)<BR> (setq p (grread t 4 0))<BR> (princ)<BR> (setq ip (car p))<BR> (setq pt (cadr p))<BR> (if (= ip 5)<BR>;;;;;;;;;;;;;;确定为坐标移动<BR> (progn<BR> (setq p1 (trans pt 1 0))<BR> ;;坐标系转换（以防止更新数据表时出错）<BR> (entdel ent)<BR> ;;删除旧的圆弧<BR> (command "arc" pt1 pt3 p1)<BR> (setq ent (entlast))<BR> (setq arc0 (entget ent))<BR> (setq r0 (rtos (cdr (assoc 40 arc0))))<BR> ;;求圆弧新的半径值并转化为字符型<BR> (setq ts2 (strcat ts1 r0 "mm"))<BR> (setq tx2 (subst (cons 10 p1) (assoc 10 tx2) tx2))<BR> (setq tx2 (subst (cons 1 ts2) (assoc 1 tx2) tx2))<BR> (entmod tx2)<BR> ;;更新文字的位置及内容
)<BR> ;;progn<BR> )<BR> ;;if<BR> (setq pick (= 3 ip))<BR>;;;确定为点取坐标<BR> )<BR> ;;while<BR> (setvar "CMDECHO" 1)<BR> (setvar "osmode" 37);;根据自身的需要可设置成相应的值<BR> ;;(entdel ent)<BR> ;;(entdel tx1)<BR> ;;(print ts2)<BR> (princ)<BR>)<BR> 蛮有创意的. 呵呵. 送朵花花 谢谢楼主，下载试用了 谢谢楼主，下载试用看看 又学了一招，顶一个 这是我想要的功能。
页:
[1]