从来人生疲画弧
本帖最后由 尘缘一生 于 2024-7-20 19:41 编辑;;两点圆弧(以弧长决定方式的探索)---
;;Modify by SLdesign V3.0 尘缘一生 QQ:15290049 2024年7月20号
(defun c:2parc (/ p1 p2 l s ang aa)
(defun inputbox-arc (dval / dcl_id dis)
(defun inputbox-dcl-arc (/ lst_str)
(setq lst_str
(list
"inputbox:dialog {"
(strcat "label=\"" (slmsg "输入弧长" "块┓" "Input arc length") "\"" ";")
"initial_focus=tile0;"
$boxed_row
(strcat "label=\"" (slmsg "弧长定式画弧" "┓﹚Α礶┓" "Determine the arc drawing method based on the arc length") "\";")
":button {label=\"2Pd<--\"; key=\"2-p-d\";}"
":tile {}"
":edit_box {"
(strcat "label=\"" (slmsg "弧长 >=" "┓ >=" "arc length >=") "\"" ";")
"key=\"tile0\";"
(strcat "value=\"" dval "\"" ";")
"edit_width=8;"
"allow_accept=true;"
"}}"
$row
":tile {}:tile {}"
$okbt $canbt
":tile {}:tile {}"
"}}"
)
)
(dcl2lisp lst_str)
)
;;---------
(defun doddarc ()
(setq Restr (rtos (* 0.9 (atof dval)) 2 2))
(set_tile "tile0" Restr)
(done_dialog 1)
)
;;---------
(setq dcl_id (load_dialog (inputbox-dcl-arc)))
(new_dialog "inputbox" dcl_id)
(action_tile "tile0" "(setq Restr $value)")
(action_tile "2-p-d" "(doddarc)")
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(done_dialog 0)");;退出
(start_dialog)
(slunloaddcl dcl_id)
Restr ;;返回字符串
)
;;---------------
(setq p1 (getpoint (slmsg "\n 圆弧第一点:" "\n 蛾┓材滁翴:" "\n First point of arc:"))
p2 (getpoint p1 (slmsg "\n 圆弧第二点:" "\n 蛾┓材翴:" "\n Second point of arc:"))
)
(setq l (rtos (* (distance p1 p2) (getvar "dimlfac")) 2 2))
(setq s (atof (strcase (inputbox-arc l))))
(setq l (atof l))
(cond
((< s l)
(2p-dd-arc p1 p2)
)
((= s l)
(command "arc" p1 "e" p2 "d")
)
((> s l)
(setq ang (4dire p1))
(if (or (= ang 0) (= ang 3pi2))
(setq aa nil)
(setq aa t)
)
(2p-d-arc p1 p2 (/ s (getvar "dimlfac")) aa)
)
)
)
;;两点动态圆弧------(一级)-----
;;Modify by SLdesign V3.0 尘缘一生 QQ:15290049 2024年7月20号
(defun 2p-dd-arc (p1 p2 / p3 nam nam1 obj nam2 ent ent1 loop bb pt f3 f8 d ang ang0 s0 s s1 s2 s3 kk)
(command "_.undo" "be")
(setq s0
(slmsg
"\n->动态圆弧 [信息开关(TAB)/扑捉(F3)/正交弧(F8)/定位(Left-Right-Other keys)]"
"\n->笆篈蛾┓ [獺秨闽(TAB)/汲(F3)/タユ┓(F8)/﹚(Left-Right-Other keys)]"
"\n->Dynamic Arc"
)
)
(setq p3 (polar (sl:mid p1 p2) (setq ang0 (+ (angle p1 p2) pi2)) 10.0) s1 "mm" s2 (slmsg "..开.." "..秨.." "..open..") s3 (slmsg "..关.." "..闽.." "..close.."))
(make-arc p1 p3 p2)
(setq nam (entlast))
(slmkwz (strcat "R=" (rtos (* (getvar "DIMLFAC") (dxf1 nam 40))) s1) p3 3.0 0 nil nil 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 nil nil 6 "m")
(setq ent1 (entget (setq nam2 (entlast))))
(setq loop t f3 (getvar "OSMODE") f8 (getvar "ORTHOMODE") 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 (slmsg "\n <对象捕捉 关>" "\n <癸禜 闽>" "\n <OSnap Off>"))
)
((or (= f3 0) (>= f3 16384))
(setq f3 16383)
(prompt (slmsg "\n <对象捕捉 开>" "\n <癸禜 秨>" "\n <OSnap On>"))
)
)
(setvar "OSMODE" f3)(redraw)
)
((equal bb '(2 15)) ;F8切换正交开关
(if (= f8 0)
(progn (setq f8 1) (prompt (slmsg "\n <正交 开>" "\n <タユ 秨>" "\n <Orth open>")))
(progn (setq f8 0) (prompt (slmsg "\n <正交 关>" "\n <タユ 闽>" "\n <Orth off>")))
)
(setvar "ORTHOMODE" f8) (redraw)
)
((= (car bb) 5)
(redraw)
(if (and (<= f3 16384) (> f3 0))
(setq pt (slosnappt nam pt) kk t)
)
(if (= f8 1)
(setq pt (pertolinecz pt p3 (polar p3 ang0 50)))
)
(grdraw (sl:mid p1 p2) pt 3 2)
(setq pt (trans pt 1 0))
(if (sl:pts-onLine (list p1 pt p2))
(setq pt p3)
)
(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)
)
)
)
(if kk (sl:erase (ssget "X" (list (cons 8 "f-i-n-d")))))
(command "_.undo" "e")
(redraw)
)
;;两点+弧长+方向画圆弧-------(一级)-----
;; s 弧长 ; aa 方向 aa=n nil 逆时针 aa=s 顺时针
;;Modify by SLdesign V3.0 尘缘一生 QQ:15290049 2024年7月20号
(defun 2p-d-arc (p1 p2 s aa / a l x xx fx flx r c c1 c2)
(setq a (angle p1 p2))
(setq l (distance p1 p2))
(setq x 2)
(setq fx (- (/ (sin (* 0.5 x)) x) (/ (* 0.5 l) s)))
(setq flx (/ (- (* 0.5 x (cos (* 0.5 x))) (sin (* 0.5 x))) (* x x)))
(setq xx (- x (/ fx flx)))
(while (> (abs (- x xx)) 0.0000000001)
(setq x xx)
(setq fx (- (/ (sin (* 0.5 x)) x) (/ (* 0.5 l) s)))
(setq flx (/ (- (* 0.5 x (cos (* 0.5 x))) (sin (* 0.5 x))) (* x x)))
(setq xx (- x (/ fx flx)))
)
(setq r (/ s xx))
(if (= aa nil) (setq aa "N") (setq aa "S"))
(cond
((= aa "N")
(setq c (- (+ a pi2) (* x 0.5)))
(setq cen (polar p1 c r))
(setq c1 (+ c pi))
(setq c2 (+ c1 x))
(vla-addarc *Model-Space* (vlax-3d-point cen) r c1 c2)
)
((= aa "S")
(setq c (- (+ a (* 0.5 x)) pi2))
(setq cen (polar p1 c r))
(setq c1 (- (+ c pi) x))
(setq c2 (+ c pi))
(vla-addarc *Model-Space* (vlax-3d-point cen) r c1 c2)
)
)
(entlast)
)
moranyuyan 发表于 2024-7-22 06:36
命令: 2PARC
; 错误: no function definition: SLMSG
不明白 Error: no function definition: SLMSG
找不到MSG
试一下用不成啊
tranque 发表于 2024-7-20 19:52
尘缘前辈最近很高产
最近主要是旧程序在改写， 尘缘前辈最近很高产 谢谢分享。 谢谢分享！ 我感觉我画直线比较多:lol 多是画特定值相切弧，不画任意弧 老爷子好诗词，高技术。 Bao_lai 发表于 2024-7-21 10:43
老爷子好诗词，高技术。
还老爷子，人家正青春:lol :lol厉害科啊。666