单行文本动态神缩

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. )
    
77. 
    
78. ;;^^^^^^^^^^^^^以上为三领集成的函数
    
79. 
    
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. )

复制代码