两点动态画弧

尘缘一生

闲来手痒，为画弧方便，新作一功能
仅为展示，测试需三领的支持
函数不复杂，字面一看即明白，换成你的即可

2. ;;两点动态圆弧------(一级)-----
   
3. ;三领设计 V3.0 Modify by 尘缘一生  QQ:15290049 2024.6.28
   
4. ;功能：给2点画弧，且提示弧长，半径，并支持扑捉，TAB键乒乓开关信息
   
5. (defun 2p-dd-arc (p1 p2 / p3 nam nam1 obj nam2 ent ent1 loop bb pt f3 d ang s0 s s1 s2 s3)
   
6.   (command "_.undo" "be")
   
7.   (setq s0 "\n->动态圆弧 [信息开关(TAB)/扑捉(F3)/定位(Left-Right-Other keys)]")
   
8.   (setq p3 (polar (sl:mid p1 p2) (+ (angle p1 p2) pi2) 50) s1 "mm" s2 "..开.." s3 "..关..")
   
9.   (make-arc p1 p3 p2) ;3P画弧
   
10.   (setq nam (entlast))
    
11.   (slmkwz (strcat "R=" (rtos (* (getvar "DIMLFAC") (dxf1 nam 40))) s1) p3 3.0 0 nil "f-i-n-d" nil 6 "m") ;中心定位写字
    
12.   (setq ent (entget (setq nam1 (entlast))) obj (en2obj nam1))
    
13.   (slmkwz (strcat "L=" (rtos (* (getvar "DIMLFAC") (sllen nam))) s1) p3 3.0 0 nil "f-i-n-d" nil 6 "m")
    
14.   (setq ent1 (entget (setq nam2 (entlast))))
    
15.   (setq loop t f3 (getvar "OSMODE") s s2)
    
16.   (princ (strcat s0 "(" s ")"))
    
17.   (while loop
    
18.     (setq bb (grread t 15 2))
    
19.     (setq pt (cadr bb) d (p2uu 20))
    
20.     (cond
    
21.       ((equal bb '(2 6));F3切换捕捉开关
    
22.         (cond
    
23.           ((and (< f3 16384) (/= f3 0))
    
24.             (setq f3 (+ f3 16384))
    
25.             (prompt "\n <对象捕捉 关>")
    
26.           )
    
27.           ((or (= f3 0) (>= f3 16384))
    
28.             (setq f3 16383)
    
29.             (prompt "\n <对象捕捉 开>")
    
30.           )
    
31.         )
    
32.         (setvar "OSMODE" f3)(redraw)
    
33.       )   
    
34.       ((= (car bb) 5)
    
35.         (redraw)
    
36.         (if (and (<= f3 16384) (> f3 0))
    
37.           (setq pt (slosnappt nam pt))
    
38.         )
    
39.         (setq pt (trans pt 1 0))
    
40.         (entdel nam)
    
41.         (make-arc p1 pt p2)
    
42.         (setq nam (entlast))
    
43.         (if (= s s2)
    
44.           (progn
    
45.             (setq ang (angle-sharp (angle '(0.0 0.0 0.0) (vlax-curve-getFirstDeriv nam (vlax-curve-getparamatpoint nam pt)))))
    
46.             (setq pt (polar pt (+ ang pi2) (* 0.7 d)))
    
47.             (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))
    
48.             (setq pt (polar pt (+ ang pi2) (* 1.3 d)))
    
49.             (entmod (emod (emod (emod (emod (emod ent1 1 (strcat "L=" (rtos (* (getvar "DIMLFAC") (sllen nam))) s1)) 10 pt) 11 pt) 40 d) 50 ang))
    
50.           )
    
51.         )
    
52.       )
    
53.       ((member bb '((2 9))) ;;table 信息关
    
54.         (entdel nam1) (entdel nam2)
    
55.         (if (not (vlax-erased-p obj)) (setq s s2) (setq s s3))
    
56.         (princ (strcat s0 "(" s ")"))
    
57.       )
    
58.       ((or t (equal (car bb) 3) (member (car bb) '(11 25)));;左、右、其余键
    
59.         (setq loop nil)
    
60.       )
    
61.     )
    
62.   )
    
63.   (command "_.undo" "e")
    
64.   (redraw)
    
65. )
    
66. ;;测试-----(需要三领支持测试)
    
67. (defun c:tt (/ p1 p2)
    
68.   (setq p1 (getpoint "\n 圆弧第一点:")
    
69.     p2 (getpoint p1 "\n 圆弧第二点:")
    
70.   )
    
71.   (2p-dd-arc p1 p2)
    
72. )

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

三领设计 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)
        )
)

尘缘一生

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

sachindkini

尘缘一生 发表于 2024-7-6 17:03
乱码？请问朋友，你用的CAD，是哪个地区，那个版本？
(getvar "SYSCODEPAGE")
用这句，是什么结果？

dear sir
im from india

1. (getvar "SYSCODEPAGE")
   
2. "ANSI_1252"

复制代码

kozmosovia

没有实际用途的显摆。

sniper1111

能不能加一个捕捉功能，对建筑弧形外轮廓还是有用的。

hubeiwdlue

牛逼，点赞。

尘缘一生

sniper1111 发表于 2024-6-28 09:31
能不能加一个捕捉功能，对建筑弧形外轮廓还是有用的。

对啊，F3即可扑捉。

228378553

这个捕捉能捕捉到象限点吗？最简单的象限点就是矩形的中心点

kexiya123

有点牛逼，牛逼，牛逼，牛逼，牛逼，牛逼，牛逼，

qazxswk

kozmosovia 发表于 2024-6-28 09:26
没有实际用途的显摆。

有源码，可以学习其中的代码。

尘缘一生

228378553 发表于 2024-6-28 11:44
这个捕捉能捕捉到象限点吗？最简单的象限点就是矩形的中心点

目前，grread下整合的扑捉函数，还做不到这一点。

bai2000

slmkwz 参数都是什么？子函数发个学习一下