elitefish
发表于 2016-6-28 17:04:52
hebi31907
发表于 2016-6-29 11:36:56
有些用处，保留学习一下谢谢
elitefish
发表于 2016-6-29 12:17:19
本帖最后由 elitefish 于 2016-6-29 20:45 编辑
Text2MText.LSP
序号代码
001.
002.
003.
004.
005.
006.
007.
008.
009.
010.
011.
012.
013.
014.
015.
016.
017.
018.
019.
020.
021.
022.
023.
024.
025.
026.
027.
028.
029.
030.
031.
032.
033.
034.
035.
036.
037.
038.
039.
040.
041.
042.
043.
044.
045.
046.
047.
048.
049.
050.
051.
052.
053.
054.
055.
056.
057.
058.
059.
060.
061.
062.
063.
064.
065.
066.
067.
068.
069.
070.
071.
072.
073.
074.
075.
076.
077.
078.
079.
080.
081.
082.
083.
084.
085.
086.
087.
088.
089.
090.
091.
092.
093.
094.
095.
096.
097.
098.
099.
100.
101.
102.
103.
104.
105.
106.
107.
108.
109.
110.
111.
112.
113.
114.
115.
116.
117.
118.
119.
120.
121.
122.
123.
124.
125.
126.
127.
128.
129.
130.
131.
132.
133.
134.
135.
136.
137.
138.
139.
140.
141.
142.
143.
144.
145.
146.
147.
148.
149.
150.
151.
152.
153.
154.
155.
156.
157.
158.
159.
160.
161.
162.
163.
164.
165.
166.
167.
168.
169.
170.
171.
172.
173.
174.
175.
176.
177.
178.
179.
180.
181.
182.
183.
184.
185.
186.
187.
188.
189.
190.
191.
192.
193.
194.
195.
196.
197.
198.
199.
200.
201.
202.
203.
204.
205.
206.
207.
208.
209.
210.
211.
212.
213.
214.
215.
216.
217.
218.
219.
220.
221.
222.
223.
224.
225.
226.
227.
228.
229.
230.
231.
232.
233.
234.
235.
236.
237.
238.
239.
240.
241.
242.
243.
244.
245.
246.
247.
248.
249.
250.
251.
252.
253.
254.
255.
256.
257.
258.
259.
260.
261.
262.
263.
264.
265.
266.
267.
268.
269.
270.
271.
272.
273.
274.
275.
276.
277.
278.
279.
280.
281.
282.
;|单行转多行|;
(defun C:EF_Text->MText ( / ss)
(EF_Text:Text->MText (ssget)
1.5 ;行距
)
)
(defun EF:MText-Make (sText ;文字
ptBase ;基点
fRecWidth ;参照矩形宽度
fHeight ;高度
fSpace ;行距比例
fAngle ;角度
iAlign ;对齐 1 2 3 4 5 6 7 8 9
iRealDist ;多行文字的行距样式（可选）： 1= 至少（将替代为较高的字符）2 = 精确（将不替代为较高的字符）
/
lstText LinkText edata str
)
(defun LinkText (lstText)
(if (cdr lstText)
(append (LinkText (cdr lstText)) (list (cons 3 (car lstText))))
(list (cons 1 (car lstText)))
)
)
(while (> (strlen sText) 250)
(setq str "")
(while (<= (strlen str) 250)
(setq c (substr sText 1 1)
sText (substr sText 2)
)
(cond ((> (ascii c) 128)
(setq c (strcat c (substr sText 1 1))
sText (substr sText 2)
)
)
)
(setq str (strcat str c))
)
(setq lstText (cons str lstText))
)
(setq lstText (cons sText lstText))
(setq edata (append (list '(0 . "MTEXT")
'(100 . "AcDbEntity")
(cons 8 (getvar 'clayer))
'(100 . "AcDbMText")
(cons 10 ptBase)
(cons 40 fHeight)
(cons 41 fRecWidth)
(cons 71 iAlign)
)
(LinkText lstText)
(list
(cons 7 (getvar 'TEXTSTYLE))
(cons 50 fAngle)
(cons 73 iRealDist)
;'(73 . 2) 多行文字的行距样式（可选）： 1= 至少（将替代为较高的字符）2 = 精确（将不替代为较高的字符）
(cons 44 (* 0.6 fSpace))
)
)
)
(if (entmake edata)
(entlast)
)
)
;选择集→元素列表
(defun EF:PickSet-toList ( ss/ i n eList)
(if ss
(progn
(setq i 0
n (sslength ss)
)
(while (< i n)
(setq eList (cons (ssname ss i) eList))
(setq i (1+ i))
)
eList
)
)
(reverse eList)
)
;删除选择集
(defun EF:PickSet-Erase (ss/ e )
(while (> (sslength ss) 0)
(setq e (ssname ss 0))
(setq ss (ssdel e ss))
(entdel e)
)
)
;将字符串字符串以 给定 Key 分解成
;例：(EF:String->list "a,b,c" ",") →("a" "b" "c")
(defun EF:String->list (sSource sDelimiter / lenSource lenDelimiter iPos lstResult)
(if (= sDelimiter "") (progn (princ "EF:String->list 分割参数不能为空字符\"\"") (exit)))
(setq
lenSource (strlen sSource)
lenDelimiter (strlen sDelimiter)
)
(while (setq iPos (vl-string-search sDelimiter sSource))
(setq
lstResult (cons (substr sSource 1 iPos) lstResult)
sSource (substr sSource (+ 1 iPos lenDelimiter))
)
)
(reverse (cons sSource lstResult))
) ;_ end EF:String->list
;将字符串中所有目标字符替换为指定字符串
;sNew 用于替换的字符串
;sOld 将被全部替换的字符串
;sSource 源字符串
(defun EF:String-Replace ( sNew sOld sSource / )
(EF:List->String (EF:String->List sSource sOld) sNew)
)
;将字符串列表以 给定 字符串连接
;例：(EF:List->string ("a" "b" "c") ",") →"a,b,c"
(defun EF:List->String (lstString Delimiter / str return)
(if lstString
(progn
(setq return (car lstString)
lstString (cdr lstString)
)
(foreach str lstString
(setq return (strcat return Delimiter str))
) ;_ end of foreach
return
);end EF:List->string
""
)
)
;单行文字转多行文字
(defun EF_Text:Text->MText (ssText ;文字选择集
fSpace ;行距比例
/
box ptLeftTop fRecWidth Mats
lstText eText edata ang
fHeight fWidth ang
lst1 lstText1
e e1 e2 box
lstReplace ename
)
(setq lstText (EF:PickSet-toList ssText))
(setq ename (ssname ssText 0))
(setq edata (entget ename)
ang (cdr (assoc 50 edata))
)
(command "UCS" "OB" ename)
;(setq Mats (EF:Matrix-3PMatrix '(0 0 0) (polar '(0 0 0) ang 1) (polar '(0 0 0) (+ (* 0.5 PI) ang) 1))) ;转换矩阵 替代 UCS
(setq lstText (mapcar '(lambda (eText / edata pt str)
(setq edata (entget eText))
(setq str (cdr (assoc 1 edata)))
;(if (= (EF:Config-getDwgKey "文字工具" "自动替换") "1")
;(setq edata (subst (cons 1 (EF_Text:AutoUnReplace str)) (assoc 1 edata) edata))
;)
(setq pt (cdr (assoc 10 edata)))
(trans pt 0 1)
;(setq pt (EF:Matrix-TransTo pt Mats 1))
(list pt edata)
)
lstText
)
)
(setq lstText (vl-sort lstText '(lambda (e1 e2) (> (cadar e1) (cadar e2)))))
(setq y (cadaar lstText))
(foreach eText lstText
(setq fHeight (cdr (assoc 40 (cadr eText))))
(if (< (abs (- y (cadar eText))) fHeight) ;同行
(progn
(setq lst1 (cons eText lst1))
(setq y (cadar eText))
)
(progn
(setq lstText1 (cons lst1 lstText1)) ;加入
(setq y (cadar eText))
(setq lst1 (list eText))
)
)
)
(if lst1 (setq lstText1 (cons lst1 lstText1)))
(setq lstText (mapcar '(lambda (lst1)
(mapcar 'cadr (vl-sort lst1 '(lambda (e1 e2) (< (caar e1) (caar e2)))))
) lstText1))
(setq lstText (reverse lstText))
(setq fRecWidth (apply 'max (mapcar '(lambda (e)
(if (> (length e) 1)
(apply '+ (mapcar '(lambda (e1 / box)
(setq box (textbox e1))
(caadr box)
)
e))
(caadr (textbox (car e)))
)
)
lstText
)))
(setq fRecWidth (* fRecWidth 1.2))
(setq fHeight (cdr (assoc 40 (caar lstText))))
(setq ptLeftTop (cdr (assoc 10 (caar lstText))))
(setq ang (cdr (assoc 50 (caar lstText))))
(setq box (textbox (caar lstText)))
(setq ptLeftTop (polar ptLeftTop ang
(apply 'min
(setq a (vl-remove nil
(mapcar '(lambda (lst / str)
(setq str (cdr (assoc 1 lst)))
(cond ((wcmatch str " *, *")
0
)
((> (ascii (substr str 1 1)) 128)
0
)
(T
(caar (textbox lst))
)
)
)
(mapcar 'car lstText)
))
))
)
)
;(if (= (EF:Config-getDwgKey "文字工具" "段落顶点") "2")
;(setq ptLeftTop (polar ptLeftTop (+ ang (* pi 0.5)) (apply 'max (mapcar 'cadadr (mapcar 'textbox (car lstText)))))) ;对齐方式2，不同字体需要不同的对齐方式
(setq ptLeftTop (polar ptLeftTop (+ ang (* pi 0.5)) (apply 'max (mapcar '(lambda (e) (cdr (assoc 40 e))) (car lstText))))) ;对齐方式1，不同字体需要不同的对齐方式
;)
(EF:PickSet-Erase ssText)
(setvar 'clayer (cdr (assoc 8 (caar lstText))))
(setvar 'TEXTSTYLE (cdr (assoc 7 (caar lstText))))
(setq fWidth (cdr (assoc 41 (tblsearch "Style" (getvar 'textstyle)))))
(setq sText (mapcar '(lambda (e)
(apply 'strcat (mapcar '(lambda (e1 / str h w c pre)
(setq str (cdr (assoc 1 e1)))
(setq h (cdr (assoc 40 e1)))
(setq w (cdr (assoc 41 e1)))
(setq c (cdr (assoc 62 e1)))
(setq str (EF:String-Replace"\\{" "{" str))
(setq str (EF:String-Replace"\\}" "}" str))
(setq pre "")
(if (not (equal h fHeight)) (setq pre (strcat pre "\\H" (rtos (/ h fHeight) 2 1) "x;")))
(if (not (equal w fWidth)) (setq pre (strcat pre "\\W" (rtos w 2 1) ";")))
(if c (setq pre (strcat pre "\\C" (rtos c 2 0) ";")))
(if (/= pre "")
(setq str (strcat "{" pre str "}"))
str
)
)
e
);end mapcar
))
lstText
))
(setq sText (EF:List->String sText "\\P"))
(command "UCS" "P")
(EF:MText-Make
sText
ptLeftTop ;基点
fRecWidth ;参照矩形宽度
fHeight ;高度
fSpace ;行距比例
ang ;角度
1 ;对齐 1 2 3 4 5 6 7 8 9
1 ;精准行距
)
)