文字动态伸缩（GIF展示）

尘缘一生 · 发表于 2022-11-28 22:35

本帖最后由尘缘一生于 2022-11-29 06:57 编辑

此为开发的中间产品。
还是采取先炸开MTEXT，处理集伸缩，最后在合并成MTEXT，这不怎么好的方式。
对于文字动态伸缩，同时变动字高的功能消除不用，因为，那种情况你几乎不需要的。

由于大动画发不上，动画只展示水平的，对倾斜的，垂直90度的，均支持。
用到一个重要的，信源码，合并TEXT到MTEXT函数，经过改写，支持垂直90度文字，贴在下面。

;单行文字选择集转多行文字----(一级)------
; 缘自信工具源码 MODIFY 尘缘一生 2022-11-29
;ssText 文字选择集 fSpace 行距比例
(defun sl-ss-txt2mtext (ssText fSpace / e_lst ptLeftTop fRecWidth Mats x y lstText eText edata fHeight fWidth ang
lst1 lstText1 e e1 e2 box lstReplace ename)
(setq e_lst (sysvar '("TEXTSTYLE" "CLAYER")))
(setq lstText (ss-enlst ssText))
(setq ename (ssname ssText 0))
(setq ang (dxf1 ename 50))
(command "UCS" "OB" ename)
(setq lstText
(mapcar
'(lambda (eText / edata pt)
(setq edata (entget eText))
(setq pt (dxf1 edata 10))
(trans pt 0 1)
(list pt edata)
)
lstText
)
)
(if (/= 1 (sin ang)) ;非垂直
(progn
(setq lstText (vl-sort lstText '(lambda (e1 e2) (> (cadar e1) (cadar e2)))))
(setq y (cadaar lstText))
(foreach eText lstText
(setq fHeight (dxf1 (cadr eText) 40))
(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))
)
)
)
)
(progn ;垂直
(setq lstText (vl-sort lstText '(lambda (e1 e2) (< (caar e1) (caar e2)))))
(setq x (caaar lstText))
(foreach eText lstText
(setq fHeight (dxf1 (cadr eText) 40))
(if (< (abs (- x (caar eText))) fHeight) ;同行
(progn
(setq lst1 (cons eText lst1))
(setq x (caar eText))
)
(progn
(setq lstText1 (cons lst1 lstText1)) ;加入
(setq x (caar eText))
(setq lst1 (list eText))
)
)
)
)
)
(if lst1 (setq lstText1 (cons lst1 lstText1)))
(setq lstText
(mapcar
'(lambda (lst1)
(mapcar 'cadr
(vl-sort lst1
(if (/= 1 (sin ang))
'(lambda (e1 e2)
(< (caar e1) (caar e2))
)
'(lambda (e1 e2)
(< (cadar e1) (cadar 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) lst1 (caar lstText))
(setq fHeight (dxf1 lst1 40))
(setq ptLeftTop (dxf1 lst1 10))
(setq ang (dxf1 lst1 50))
(setq box (textbox lst1))
(setq ptLeftTop
(polar ptLeftTop ang
(apply 'min
(setq a
(vl-remove nil
(mapcar
'(lambda (lst / str)
(setq str (dxf1 lst 1))
(cond
((wcmatch str " *,　*") 0)
((> (ascii (substr str 1 1)) 128)
0
)
(T
(caar (textbox lst))
)
)
)
(mapcar 'car lstText)
)
)
)
)
)
)
(setq ptLeftTop (polar ptLeftTop (+ ang pi2) (apply 'max (mapcar '(lambda (e) (dxf1 e 40)) (car lstText)))))
(sl:-erase ssText)
(setvar 'clayer (dxf1 lst1 8))
(setvar 'TEXTSTYLE (dxf1 lst1 7))
(setq fWidth (dxf1 (tblsearch "Style" (getvar 'textstyle)) 41))
(setq sText
(mapcar
'(lambda (e)
(apply
'strcat
(mapcar
'(lambda
(e1 / str h w c pre)
(setq str (dxf1 e1 1))
(setq h (dxf1 e1 40))
(setq w (dxf1 e1 41))
(setq c (dxf1 e1 62))
(setq str (t-string-subst "\\{" "{" str))
(setq str (t-string-subst "\\}" "}" 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
)
)
)
lstText
)
)
(setq sText (slist->String sText "\\P"))
(command "UCS" "")
(Make-MText sText ptLeftTop fRecWidth fHeight fSpace ang 1 1)
(mapcar 'eval e_lst)
)

mokson · 发表于 2023-3-24 08:14

最后出现了两个笑脸，是什么字母？

guosheyang · 发表于 2023-3-26 19:39

模仿下大佬的功能用的是修改文字样式方法

戏男 · 发表于 2023-6-8 11:12

最后出现了两个笑脸，是什么字母？

magicheno · 发表于 2022-11-29 00:46

大佬，给力~~~

中国梦 · 发表于 2022-11-29 05:30

感谢楼主分享！！！

hoodpinrh · 发表于 2022-11-29 07:54

感謝樓主分享
學習一下

行天下 · 发表于 2022-11-29 08:13

感谢楼主分享！！！

cghdy · 发表于 2022-11-29 09:11

лл

czb203 · 发表于 2022-11-29 09:38

感謝樓主分享
學習一下

624617205 · 发表于 2022-11-29 16:01

大佬，给力~~~

w379106181 · 发表于 2022-12-1 08:02

感谢楼主分享！！！

ZYX2129 · 发表于 2022-12-3 13:08

感謝樓主分享，有点高大尚

账号		自动登录	找回密码
密码			注册

文字动态伸缩（GIF展示）

本帖子中包含更多资源

本帖子中包含更多资源