两点动态圆弧------(一级)-----
;;两点动态圆弧------(一级)-----;功能：给2点画弧，且提示弧长，半径，并支持扑捉，TAB键乒乓开关信息
(defun 2p-dd-arc (p1 p2 / p3 nam nam1 obj nam2 ent ent1 loop bb pt f3 d ang s0 s s1 s2 s3)
(command "_.undo" "be")
(setq s0 "\n->动态圆弧 [信息开关(TAB)/扑捉(F3)/定位(Left-Right-Other keys)]")
(setq p3 (polar (sl:mid p1 p2) (+ (angle p1 p2) pi2) 50) s1 "mm" s2 "..开.." s3 "..关..")
(make-arc p1 p3 p2) ;3P画弧
(setq nam (entlast))
(slmkwz (strcat "R=" (rtos (* (getvar "DIMLFAC") (dxf1 nam 40))) s1) p3 3.0 0 nil "f-i-n-d" nil 6 "m") ;中心定位写字
(setq ent (entget (setq nam1 (entlast))) obj (en2obj nam1))
(slmkwz (strcat "L=" (rtos (* (getvar "DIMLFAC") (sllen nam))) s1) p3 3.0 0 nil "f-i-n-d" nil 6 "m")
(setq ent1 (entget (setq nam2 (entlast))))
(setq loop t f3 (getvar "OSMODE") s s2)
(princ (strcat s0 "(" s ")"))
(while loop
(setq bb (grread t 15 2))
(setq pt (cadr bb) d (p2uu 20))
(cond
((equal bb '(2 6));F3切换捕捉开关
(cond
((and (< f3 16384) (/= f3 0))
(setq f3 (+ f3 16384))
(prompt "\n <对象捕捉 关>")
)
((or (= f3 0) (>= f3 16384))
(setq f3 16383)
(prompt "\n <对象捕捉 开>")
)
)
(setvar "OSMODE" f3)(redraw)
)
((= (car bb) 5)
(redraw)
(if (and (<= f3 16384) (> f3 0))
(setq pt (slosnappt nam pt))
)
(setq pt (trans pt 1 0))
(entdel nam)
(make-arc p1 pt p2)
(setq nam (entlast))
(if (= s s2)
(progn
(setq ang (angle-sharp (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt)))))
(setq pt (polar pt (+ ang pi2) (* 0.7 d)))
(entmod (emod (emod (emod (emod (emod ent 1 (strcat "R=" (rtos (* (getvar "DIMLFAC") (dxf1 nam 40))) s1)) 10 pt) 11 pt) 40 d) 50 ang))
(setq pt (polar pt (+ ang pi2) (* 1.3 d)))
(entmod (emod (emod (emod (emod (emod ent1 1 (strcat "L=" (rtos (* (getvar "DIMLFAC") (sllen nam))) s1)) 10 pt) 11 pt) 40 d) 50 ang))
)
)
)
((member bb '((2 9))) ;;table 信息关
(entdel nam1) (entdel nam2)
(if (not (vlax-erased-p obj)) (setq s s2) (setq s s3))
(princ (strcat s0 "(" s ")"))
)
((or t (equal (car bb) 3) (member (car bb) '(11 25)));;左、右、其余键
(setq loop nil)
)
)
)
(command "_.undo" "e")
(redraw)
)
;;测试-----(需要三领支持测试)
(defun c:tt (/ p1 p2)
(setq p1 (getpoint "\n 圆弧第一点:")
p2 (getpoint p1 "\n 圆弧第二点:")
)
(2p-dd-arc p1 p2)
)
页:
[1]