单行文本动态神缩

tlmjg

1. ;将角度修正到0~2π之间-----(一级)-------
2. (defun Angle-Mod (ang /)
3.   (while (>= ang 2pi) (setq ang (- ang 2pi)))
4.   (while (< ang 0) (setq ang (+ ang 2pi)))
5.   ang
6. )
7. ;角度转换至1,4象限----(一级)------
8. ;(angle-sharp ang)
9. (defun angle-sharp (ang)
10.   (setq ang (Angle-Mod ang))
11.   (if (and (> ang pi2) (< ang pi)) (setq ang (+ ang pi)))
12.   (if (and (>= ang pi) (<= ang 3pi2)) (setq ang (- ang pi)))
13.   (if (equal ang 3pi2 0.01) (setq ang pi2))
14.   (if (equal ang 2pi 0.01) (setq ang 0))
15.   ang
16. )
17. ;更新图元定义数据内容----(一级)------
18. ;ent 为实体nam obj 或实体表 entget
19. (defun emod (ent i n / tp)
20.   (setq tp (type ent))
21.   (cond
22.     ((= tp 'VLA-OBJECT)
23.       (setq ent (entget (obj2en ent) '("*")))
24.     )
25.     ((= tp 'ENAME)
26.       (setq ent (entget ent '("*")))
27.     )
28.   )
29.   (if (= (assoc i ent) nil)
30.     (entmod (append ent (list (cons i n))))
31.     (subst (cons i n) (assoc i ent) ent)
32.   )
33. )
34. ;取得图元参数值内容-----(一级)-------
35. ;(setq h (dxf1 ent 40))
36. ;ent 为实体nam obj 或实体表 entget
37. (defun dxf1 (ent i / tmp tp)
38.   (setq tp (type ent))
39.   (cond
40.     ((= tp 'VLA-OBJECT)
41.       (setq ent (entget (obj2en ent) '("*")))
42.     )
43.     ((= tp 'ENAME)
44.       (setq ent (entget ent '("*")))
45.     )
46.   )
47.   (setq tmp (cdr (assoc i (vl-remove-if-not '(lambda (x) (= (car x) i)) ent))))
48.   (if (null tmp)
49.     (cond
50.       ((= i 66) 0)
51.       ((= i 48) (getvar "CELTSCALE"))
52.       ((member i '(6 62))
53.         (cdr (assoc i (entget (tblobjname "LAYER" (cdr (assoc 8 ent)))))) ;对象所在图层颜色
54.       )
55.       ((= i 370) -1)
56.       ((= i 7) $hz)
57.     )
58.     tmp
59.   )
60. )
61. ;计算cp到p1 p2的垂足点----(一级)------
62. (defun pertolinecz (cp p1 p2 / norm)
63.   (setq norm (mapcar '- p2 p1)
64.     p1 (trans p1 0 norm)
65.     cp (trans cp 0 norm)
66.   )
67.   (trans (list (car p1) (cadr p1) (caddr cp)) norm 0)
68. )
69. ;;返回 vla对象->ename对象名-------(一级)------
70. (defun obj2en (object)
71.   (if (equal (type object) 'vla-object)
72.     (setq object (vlax-vla-object->ename object))
73.     object
74.   )
75.   object
76. )
78. ;;^^^^^^^^^^^^^以上为三领集成的函数
80. ;;单行TEXT文本选择集-动态拉伸---(一级)----
81. ;;功能 程序去除文字的前面空格,后面的空格,进行整体(各自单独)动态伸缩,保持角度,定位点不变
82. ;三领设计 V3.0 Modify by 尘缘一生  QQ:15290049 2024.8.3 (精简后代码)
83. (defun macedit-text (ss / ms1 ms2 ms3 pt bb loop p0 kk)
84.   (defun sskk (ss pt kk / enam ent p tx ang i n m)
85.     (setq n (sslength ss) m 0)
86.     (while (< m n)
87.       (setq enam (ssname ss m))
88.       (setq ent (entget enam) p (dxf1 ent 10) tx (dxf1 ent 1) ang (angle-sharp (dxf1 enam 50)))
89.       (while (= (substr tx 1 1) " ")
90.         (setq tx (substr tx 2))
91.       )
92.       (setq i (strlen tx))
93.       (while (= (substr tx i 1) " ")
94.         (setq tx (substr tx 1 (1- i)) i  (strlen tx))
95.       )
96.       (if kk
97.         (entmod (emod (emod (emod (emod ent 1 tx) 11 (pertolinecz pt p (polar p ang 300.0))) 72 5) 73 0)) ;变F(双穴点)定位,去前后空格,确保右侧对齐光标点
98.         (entmod (emod (emod (emod (emod ent 1 tx) 11 (polar p ang (* 0.2 (distance pt p0)))) 72 5) 73 0))
99.       )
100.       ;(if (if-color) (vla-put-color (en2obj enam) (atoi (slsjqs))))
101.       (setq m (1+ m))
102.     )
103.   )
104.   ;;-------------
105.   (setq ms1 "\n 文本动态伸缩>>>[对齐方式切换(TAB)](左、右键>退出)"
106.     ms2 "当前<整体对齐伸缩>:"
107.     ms3 "当前<各自伸缩>:"
108.   )
109.   (princ (strcat ms1 ms2))
110.   (setq loop t kk t p0 (cadr (grread 5)))
111.   (while loop
112.     (setq bb (grread t 15 2) pt (cadr bb))
113.     (cond
114.       ((member bb '((2 9)));;table 键
115.         (if (= kk t)
116.           (progn (setq kk nil) (princ (strcat ms1 ms3)))
117.           (progn (setq kk t) (princ (strcat ms1 ms2)))
118.         )
119.       )
120.       ((= (car bb) 5)
121.         (sskk ss pt kk)
122.       )
123.       ((member (car bb) '(3 11 25))  ;;左键 右键 定位退出
124.         (setq loop nil)
125.       )
126.     )
127.   )
128.   ;(while (setq enam (ssname ss 0)) ;等同于(vl-cmdf "_.JustifyText" ss "" "L")
129.   ;  (text:alignmod enam "L")
130.   ;  (ssdel enam ss)
131.   ;)
132.   (princ)
133. )
134. ;;测试:框选TEXT,文字实体动态拉伸
135. (defun c:tt ()
136.   (princ "请选择文字->")
137.   (macedit-text (ssget ":S" '((0 . "TEXT"))))
138. )

复制代码