两点动态画弧
本帖最后由 尘缘一生 于 2024-6-28 09:36 编辑闲来手痒，为画弧方便，新作一功能
仅为展示，测试需三领的支持
函数不复杂，字面一看即明白，换成你的即可
;;两点动态圆弧------(一级)-----
;三领设计 V3.0 Modify by 尘缘一生QQ:15290049 2024.6.28
;功能：给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)
)三领设计 V3.0 永久下载地址：
链接：https://pan.baidu.com/s/1WsH2nmBHUhb0T3STais1Hg
提取码：i2uj
bai2000 发表于 2024-6-28 21:00
slmkwz 参数都是什么？子函数发个学习一下
;;写文字------(一级)---------
;;(slmkwz文字基点高度角度宽高比图层字型颜色方式 t= "m" 中心对齐 "z" 左对齐)
;;(slmkwz "XZY" (getpoint) nil nil nil "0sx" "hz" 7 "z")
(defun slmkwz (s p0 h ang bk ly sty col k / elist elist1)
(setq elist
(list'(0 . "TEXT") (cons 1 s)
(if ly
(cons 8 ly) ;图层
(cons 8 (getvar "CLAYER"))
)
(if col
(cons 62 col) ;颜色
(cons 62 (atoi (slsjqs)))
)
(if sty
(cons 7 sty)
(cons 7 $hz)
)
(if p0
(cons 10 p0)
(cons 10 (setq p0 (cadr (grread 5))))
)
(if h
(cons 40 (* slbl h))
(cons 40 (* slbl 5.0))
)
(if ang
(cons 50 ang)
(cons 50 0.0)
)
(if bk
(cons 41 bk)
(cons 41 0.7)
)
)
)
(setq elist1 (list (cons 72 1) (cons 11 p0) (cons 73 2)))
(if (= k "m")
(entmake (append elist elist1))
(entmake elist)
)
) 本帖最后由 尘缘一生 于 2024-7-1 15:25 编辑
sachindkini 发表于 2024-7-1 13:11
dear sir,
thanks for sharing
your toll are very flexible for use
三领的集成，是自动判定版本的，英文版CAD安装，就是英文版的了。
英文版，可以改一下解压目录名字为：D:\SLdesign可以下载手动安装版本 ZIP
也可以EXE安装完，改这个解压目录名即可
链接：https://pan.baidu.com/s/1NSuDJkZC2_XNf6BgX6y5hw
提取码：tk8c
尘缘一生 发表于 2024-7-6 17:03
乱码？请问朋友，你用的CAD，是哪个地区，那个版本？
(getvar "SYSCODEPAGE")
用这句，是什么结果？
dear sir
im from india
(getvar "SYSCODEPAGE")
"ANSI_1252" 没有实际用途的显摆。 能不能加一个捕捉功能，对建筑弧形外轮廓还是有用的。
牛逼，点赞。 sniper1111 发表于 2024-6-28 09:31
能不能加一个捕捉功能，对建筑弧形外轮廓还是有用的。
对啊，F3即可扑捉。 这个捕捉能捕捉到象限点吗？最简单的象限点就是矩形的中心点 有点牛逼，牛逼，牛逼，牛逼，牛逼，牛逼，牛逼， kozmosovia 发表于 2024-6-28 09:26
没有实际用途的显摆。
有源码，可以学习其中的代码。 228378553 发表于 2024-6-28 11:44
这个捕捉能捕捉到象限点吗？最简单的象限点就是矩形的中心点
目前，grread下整合的扑捉函数，还做不到这一点。 slmkwz 参数都是什么？子函数发个学习一下
页:
[1]
2