BrianTFC 发表于 2022-7-5 13:20:12

文字拟合lisp

大家好，
 
我想知道是否有一个lisp例程，当你把一个dtext字符串放到一个矩形中时，它会缩小到适合里面？我查看了express工具中的“文字拟合”命令，但它只会收缩或拉伸长度。
 
谢谢
布瑞恩

BIGAL 发表于 2022-7-5 13:26:30

文本属性之一是宽度因子，因此对于矩形，将文本高度设置为矩形高度宽度因子可能需要一个模糊因子，因为III与AAA的长度不同，因此取决于实际文本内容，这称为紧排。我会做一些像+或-或=重复接受的事情来获得效果。可能搜索Kern文本
 
使用多行文字和备用文本编辑器（带扩展（或收缩）字母间距的\T修饰符）发现此问题。

hmsilva 发表于 2022-7-5 13:27:40

布莱恩，
“快速工具”命令“文本拟合”使用宽度因子收缩或拉伸文本字符串以匹配所需的长度，如果我理解正确，您还需要高度匹配。
也许是这样的
 

(defun c:test (/      ss   esel   txtobj old_osmll ur
       ll1    ur1    llpt   urpt   ulpt   brptllpt1 urpt1
       ulpt1brpt1scf    nscf
      )
(prompt "\n Select the rectangle to fit text inside: ")
(if
   (and (setq ss (ssget "_:S:E" '((0 . "LWPOLYLINE"))))
(setq esel (entsel "\nSelect the text to fit in the rectangle: "))
   )
    (progn
      (setq txtobj (vlax-ename->vla-object (car esel)))
      (if (equal (vla-get-ObjectName txtobj) "AcDbText")
(progn
   (setq old_osm (getvar "osmode"))
   (setvar "osmode" 0)
   (vla-getboundingbox
   (vlax-ename->vla-object (ssname ss 0))
   'll
   'ur
   )
   (vla-getboundingbox txtobj 'll1 'ur1)
   (setq llpt(trans (vlax-safearray->list ll) 0 1)
urpt(trans (vlax-safearray->list ur) 0 1)
ulpt(list (car llpt) (cadr urpt) (caddr urpt))
brpt(list (car urpt) (cadr llpt) (caddr llpt))
llpt1 (trans (vlax-safearray->list ll1) 0 1)
   )
   ;; setq
   (vl-cmdf "move" (car esel) "" llpt1 llpt)
   (vla-update txtobj)
   (vla-getboundingbox txtobj 'll1 'ur1)
   (setq llpt1 (trans (vlax-safearray->list ll1) 0 1)
urpt1 (trans (vlax-safearray->list ur1) 0 1)
ulpt1 (list (car llpt1) (cadr urpt1) (caddr urpt1))
   )
   ;; setq
   (vl-cmdf "scale" (car esel) "" llpt "R" "@" ulpt1 ulpt "")
   (vla-update txtobj)
   (vla-getboundingbox txtobj 'll1 'ur1)
   (setq llpt1 (trans (vlax-safearray->list ll1) 0 1)
urpt1 (trans (vlax-safearray->list ur1) 0 1)
brpt1 (list (car urpt1) (cadr llpt1) (caddr llpt1))
scf   (vla-get-scalefactor txtobj)
nscf(/ (* (distance llpt brpt) scf) (distance llpt1 brpt1))
   )
   ;; setq
   (vla-put-scalefactor txtobj nscf)
   (setvar "osmode" old_osm)
)
;; progn
      )
      ;; if
    )
    ;; progn
)
;; if
)

 
亨里克

BrianTFC 发表于 2022-7-5 13:31:31

亨里克，
 
我想知道是否有办法缩小文本以适应内部，而不是拉伸和收缩以适应？
 
谢谢
布瑞恩
 

文本收缩。图纸

Lee Mac 发表于 2022-7-5 13:35:44

尝试以下快速编写的代码：
 

(defun c:tfit ( / ln pl pt tx )
   (if
       (and
         (setq pl (LM:selectifobject "\nSelect LWPolyline: " "LWPOLYLINE"))
         (setq tx (LM:selectifobject "\nSelect Text: " "TEXT"))
         (setq pl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl)))
               ln (length pl)
               pt (mapcar '/ (apply 'mapcar (cons '+ pl)) (list ln ln))
               tx (entget tx)
         )
       )
       (entmod
         (subst '(72 . 1) (assoc 72 tx)
               (subst '(73 . 2) (assoc 73 tx)
                   (subst (cons 10 pt) (assoc 10 tx)
                     (subst (cons 11 pt) (assoc 11 tx)
                           (subst
                               (cons 40
                                 (* 0.8 ;; Text Gap
                                       (-
                                           (cadr (apply 'mapcar (cons 'max pl)))
                                           (cadr (apply 'mapcar (cons 'min pl)))
                                       )
                                 )
                               )
                               (assoc 40 tx)
                               tx
                           )
                     )
                   )
               )
         )
       )
   )
   (princ)
)
   
;; Select if Object-Lee Mac
;; Continuously prompts the user for a selection of a specific object

(defun LM:SelectifObject ( msg obj / ent )
   (while
       (progn (setvar 'errno 0) (setq ent (car (entsel msg)))
         (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (= 'ename (type ent))
                   (if (/= obj (cdr (assoc 0 (entget ent))))
                     (princ "\nInvalid Object Selected.")
                   )
               )
         )
       )
   )
   ent
)
(princ)

 
如有必要，调整突出显示的文字间距。

BrianTFC 发表于 2022-7-5 13:38:13

李，
 
这正是我想要的，在看了你的代码后，我找到了一行，如果我需要把文本缩小，我可以。我真的很感谢你们在CadForum上给我的帮助。我正在慢慢地但肯定地学习如何编写小的简单例程，但我在阅读代码和学习每一行通过可视化Lisp编辑器所做的事情方面越来越好，Henrique aka（hmsilvia）向我展示了如何为Lisp例程设置动画，以便我能够理解它的工作原理。
 
再次感谢各位，
布瑞恩

Lee Mac 发表于 2022-7-5 13:40:22

欢迎您，Brian，当然，如果您对代码有任何问题，请提问。

vanowm 发表于 2022-7-5 13:42:41

你好
 
李，谢谢你的代码，它可以工作，但不是在所有情况下都可以。例如：
https://www.cadtutor.net/forum/image/png;base64，Ivborw0kggoaaansuheugaaamqaaaadycaiaadk5gjmaakzeleqvr4no3d2xabyhiaup7/p3ufcppjxdzg0emney8eddtqddmypbwhaaaaaaaaaaaaaaaaaaaakg8hjkpafaw4ealdwcl2hdz0juarwy4eekdwci23lz0dmarg25eegewia03l70dwmsgm5feqxcv18th9lxvvlyc6pdxcpfw6uvsxyjhnvej5xybjwzfnzfzfzfzfgzfwwzfwwzfwzfwwzfwwzfwzfwzfwzfwzfwwwliulfdueq4/a6u9tey6g3dtmdhazkul6twimyzouo5g31v9pp7j4urp4cqqmcqiovpcjes61dssn5b/Bd+dtnTNPxG0faBaPEQ18e1YljWodhhvL3yL75YO/+BmnSLUFtBqGAI6vMfKQ3LOhQ7hjvL/vrrtWkf2Di7QZxICOrLJdLk8WhBsQO4uebfesk27T/+gmwIQcIgqO/Wh2FZh2Lvdn/Bv/uqbdo/k0byleqfani8owreoxt3q02m+8cJv2Davbt4XtARDU+cowlotq7h2elv7r92m/sjk3bvsqxflwhmudir3jghv++XbZ7fe+it2vdwjgzz1khzehmw5oyyvmhyudlwpa4jg4hv Nykzlnuodl6gzy9bk5hhwydi52vy9rg1irmwdsh2xozlj1utmgfzh2lnzvj2udwjgzz1khzehmww5oyyvmhyudlwpa4nykzlnuodl6gzy9bk9jsytnvmhteh2hpsgpw3ltre1lvc11a1mhp97vymwpi1484rthC6mdXV/Z+5o9/pE+VGJWXTHKF/rSC0dcmynQFMLpDDG32VYVhb1H+DNEG6VUDUYXJ9MU6JR0RPZPPWPBGVKOVJJVFPSTW3WOBRLM9XZDPZH7VIRA1LKO+TCXC5m3oT1XS8+sayrTyzKJ3PdNAfL+Q6QRW7KutolxU6MRXK54/vs8/6JQ4TR5C7SMNZBDM8/SKKdbFYOu85TT3vmydbuFDRvO/BSWAORSIGvrzXTRZXT VT3NN/VhefUt6d51frWZQitxK9q9kUj+b/6+TpoVdYNWrAtf51WoGBUmsavOq5nVm8t+9OpZ0hEtfkPY6+7HIkf+QF58OS1ZVO1C1RZ31HZSZ4JXK1BVOOO6BHL85MAZFW1C1XZOJPTG+0diznCG3ULVuCBHbd4/qegwvxtxnw8zz5yrsolrzhvbfqvhwjltch6lgvlu7vzwvmxo+jltjgud4u25hyjyp4xbsh0qrvdxovc3rzk2mtwrvsyj3klbjepp7bjl9is6zfw1c1xzonm34y9r1bgai9ysw4bil+i4rxuoql5vo1czmpmv6nx2rn8l9uu2u97kow1oqkfxvzlxn68yzjp9urgprnhut60lx9zx5zx5gusefqve1bzopm7yb 8LVE1q3fvxf0vhoy6xz7rlv7vzvvm6mgj4mhnqn02fx5jx9sutrajp1e1c1c1xzounflpsyluvvfbxnor2rmqez3xn8tndmtct96rbelpve1c1bzoedfsjozllvvv1tbx9kp2rmpez3zochpdmt92qbeHpVO1c1rzO+wWcTwzLXrfdqm3h6VTtXNa8zvht2E8My1633apt4elU7VzWvM+9+d7f/dWQQwzLXrfdqm3h6VTtXNa8z72T8Vn06FvMdhmWuW+/VNVH0QNAual5NLMD8OZGD63MZYZNRNU1TTY9QV8PT8CVES3J25XPWnJRDMV1T35Y+T6V7DNKANBFPPKOHES3RHDZ3WB5PN9CKK9KTLNIC5VK/DRB5KE8HLEB3U+lHpZHzid0+7HNCUDGTO/Zauk9XI8TX1gZVoX+SvZh+WR8AkNMnFj3osp0j0ke28R2vfZD69M91L/rcCwPLI9oaGGbpC7MFeZ360sx+823EmVUfA/agzLI9UTGnDu7ro+IXIWDXVADVFWLBCF/HIV1TZVBL+Lf9zzdn5lmncr2wllezyxnkeuljx3dsndmmwfvrmj/+7sMlf4aHVylYXkkeULjX9NzUU3ST1nNuFR6HypR4wWDLIoNyyPDExr8ss2fiJpSfzjXivzL72Jk/wUonXrD8gj/hEa+cudnIbHXYz1jS+l1HFsf1LYdGbCSX/cvejqvmbfjmierpkr56r3aijbcvpqoybebl56b7cidtcvqnyxiabl94blgldzuvvabz5otifaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa aaaaaaaaaaaaaaaaaaaaaaawcuvh8phcdjihbgecwia9slnpnabadbeunkuliaa2gs3m8ifbeb74wztuiaac/cbAoXEADthZtN4QICoL1wsylcQAC0F242hQsIgPbCzaZwAQHQXrjZFC4gNnu9BqyJIRfhXc/L/vrKkMB+9PwulBJuRYQLiJ2GbFv2vi2el/270yddduxdqcgcgxenv82q2g7iw2vswel/383NtXfutEy4b/hFsL4QJijz/7116330年1月voyxznxxxnejn4rzguidy4omonwtteutm7x3z39sttauf24vhaui1f7zm+5tVUMuwrtm9G7ID6/5myevhc4qjiqqc+70pcxx zmx2c0zq3fntvkgaacl1p1xabgany8uwpi5w/Q8XEJvZ6fIyLKkjXP/DBcRmdrq8DEvqCNf/cagxmzoul8ososol1p1xabfz7p5pdglnqf5lfwvu/XEBsVn6nK/yphiDD8t5lh1+B3ML1P1xAbFZ+WB51Py8fZ1jeu/LA00kvXP/dbcrmhyblufsb2einy3xh3iufytrf7ia2kzjsdxwfxnbstgg5b3rpzyrisl1xabnznwb6rxlfcjucwvhel22drr7j+hwuizvony2pvezidksf51yw7t3ozrw/q8xej1g5bhalletl7yg25ks944fofliaazgsj28crpffnusfd8bgvx/3ABsVnPYXl8irlACnFOuSFj/RkpXP/DBcRmbYfl8SHs7PFHO+wgpc1Gmhd9f9 DXCQM3uelsfvt6lsjuimw5i6wvu/xebszlimdj7mktfk7qjjot/uIDYrPOw9DLspFMC3oLowi2BcAGxWdth6Q0+804jdx1ycckwgxezj2hpy+otd0lymxjnxccbcqmzuclr6uYPYp269MPuHWQriA2KzbsPwx1Eq57Dpl42XJKtxyCBcQm7UalhfjLJbOk7NMShYJtyLCBcRmfYZlhCEx1u0g9/7SKKK2RBBZUYQLIM2ADMS4LZ8O9CTCXS9HX68QE4RBF+ECYRMO3L2V8B2MTSCTUPWC7C0WGXEZUWH5CPYQZMURJBUNRLICWEL3Z/CJR0VLRPV8FZPR9UU8ILWMCCRDAWGUEQHVHZLO4GABOL9XSCHCQAO2FM03HAGGGVXEL3Z Czkvxaalqxbjafcwia9slnpnabadbeunkuliaa2gs3m8ifbeb74wztuiaac/cbho5ha6hwxhvaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaacgsf8BAJz/gphzokqaaaasuvork5cyii=http://i.imgur.com/x9Cehk3.png
https://www.cadtutor.net/forum/image/png;base64，Ivborw0kggoaaansuheugaaamqaaaadycaiaadk5gjmaakzeleqvr4no3d2xabyhiaup7/p3ufcppjxdzg0emney8eddtqddmypbwhaaaaaaaaaaaaaaaaaaaakg8hjkpafaw4ealdwcl2hdz0juarwy4eekdwci23lz0dmarg25eegewia03l70dwmsgm5feqxcv18th9lxvvlyc6pdxcpfw6uvsxyjhnvej5xybjwzfnzfzfzfzfgzfwwzfwwzfwzfwwzfwwzfwzfwzfwzfwzfwwwliulfdueq4/a6u9tey6g3dtmdhazkul6twimyzouo5g31v9pp7j4urp4cqqmcqiovpcjes61dssn5b/Bd+dtnTNPxG0faBaPEQ18e1YljWodhhvL3yL75YO/+BmnSLUFtBqGAI6vMfKQ3LOhQ7hjvL/vrrtWkf2Di7QZxICOrLJdLk8WhBsQO4uebfesk27T/+gmwIQcIgqO/Wh2FZh2Lvdn/Bv/uqbdo/k0byleqfani8owreoxt3q02m+8cJv2Davbt4XtARDU+cowlotq7h2elv7r92m/sjk3bvsqxflwhmudir3jghv++XbZ7fe+it2vdwjgzz1khzehmw5oyyvmhyudlwpa4jg4hv Nykzlnuodl6gzy9bk5hhwydi52vy9rg1irmwdsh2xozlj1utmgfzh2lnzvj2udwjgzz1khzehmww5oyyvmhyudlwpa4nykzlnuodl6gzy9bk9jsytnvmhteh2hpsgpw3ltre1lvc11a1mhp97vymwpi1484rthC6mdXV/Z+5o9/pE+VGJWXTHKF/rSC0dcmynQFMLpDDG32VYVhb1H+DNEG6VUDUYXJ9MU6JR0RPZPPWPBGVKOVJJVFPSTW3WOBRLM9XZDPZH7VIRA1LKO+TCXC5m3oT1XS8+sayrTyzKJ3PdNAfL+Q6QRW7KutolxU6MRXK54/vs8/6JQ4TR5C7SMNZBDM8/SKKdbFYOu85TT3vmydbuFDRvO/BSWAORSIGvrzXTRZXT VT3NN/VhefUt6d51frWZQitxK9q9kUj+b/6+TpoVdYNWrAtf51WoGBUmsavOq5nVm8t+9OpZ0hEtfkPY6+7HIkf+QF58OS1ZVO1C1RZ31HZSZ4JXK1BVOOO6BHL85MAZFW1C1XZOJPTG+0diznCG3ULVuCBHbd4/qegwvxtxnw8zz5yrsolrzhvbfqvhwjltch6lgvlu7vzwvmxo+jltjgud4u25hyjyp4xbsh0qrvdxovc3rzk2mtwrvsyj3klbjepp7bjl9is6zfw1c1xzonm34y9r1bgai9ysw4bil+i4rxuoql5vo1czmpmv6nx2rn8l9uu2u97kow1oqkfxvzlxn68yzjp9urgprnhut60lx9zx5zx5gusefqve1bzopm7yb 8LVE1q3fvxf0vhoy6xz7rlv7vzvvm6mgj4mhnqn02fx5jx9sutrajp1e1c1c1xzounflpsyluvvfbxnor2rmqez3xn8tndmtct96rbelpve1c1bzoedfsjozllvvv1tbx9kp2rmpez3zochpdmt92qbeHpVO1c1rzO+wWcTwzLXrfdqm3h6VTtXNa8zvht2E8My1633apt4elU7VzWvM+9+d7f/dWQQwzLXrfdqm3h6VTtXNa8z72T8Vn06FvMdhmWuW+/VNVH0QNAual5NLMD8OZGD63MZYZNRNU1TTY9QV8PT8CVES3J25XPWnJRDMV1T35Y+T6V7DNKANBFPPKOHES3RHDZ3WB5PN9CKK9KTLNIC5VK/DRB5KE8HLEB3U+lHpZHzid0+7HNCUDGTO/Zauk9XI8TX1gZVoX+SvZh+WR8AkNMnFj3osp0j0ke28R2vfZD69M91L/rcCwPLI9oaGGbpC7MFeZ360sx+823EmVUfA/agzLI9UTGnDu7ro+IXIWDXVADVFWLBCF/HIV1TZVBL+Lf9zzdn5lmncr2wllezyxnkeuljx3dsndmmwfvrmj/+7sMlf4aHVylYXkkeULjX9NzUU3ST1nNuFR6HypR4wWDLIoNyyPDExr8ss2fiJpSfzjXivzL72Jk/wUonXrD8gj/hEa+cudnIbHXYz1jS+l1HFsf1LYdGbCSX/cvejqvmbfjmierpkr56r3aijbcvpqoybebl56b7cidtcvqnyxiabl94blgldzuvvabz5otifaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa aaaaaaaaaaaaaaaaaaaaaaawcuvh8phcdjihbgecwia9slnpnabadbeunkuliaa2gs3m8ifbeb74wztuiaac/cbAoXEADthZtN4QICoL1wsylcQAC0F242hQsIgPbCzaZwAQHQXrjZFC4gNnu9BqyJIRfhXc/L/vrKkMB+9PwulBJuRYQLiJ2GbFv2vi2el/270yddduxdqcgcgxenv82q2g7iw2vswel/383NtXfutEy4b/hFsL4QJijz/7116330年1月voyxznxxxnejn4rzguidy4omonwtteutm7x3z39sttauf24vhaui1f7zm+5tVUMuwrtm9G7ID6/5myevhc4qjiqqc+70pcxx zmx2c0zq3fntvkgaacl1p1xabgany8uwpi5w/Q8XEJvZ6fIyLKkjXP/DBcRmdrq8DEvqCNf/cagxmzoul8ososol1p1xabfz7p5pdglnqf5lfwvu/XEBsVn6nK/yphiDD8t5lh1+B3ML1P1xAbFZ+WB51Py8fZ1jeu/LA00kvXP/dbcrmhyblufsb2einy3xh3iufytrf7ia2kzjsdxwfxnbstgg5b3rpzyrisl1xabnznwb6rxlfcjucwvhel22drr7j+hwuizvony2pvezidksf51yw7t3ozrw/q8xej1g5bhalletl7yg25ks944fofliaazgsj28crpffnusfd8bgvx/3ABsVnPYXl8irlACnFOuSFj/RkpXP/DBcRmbYfl8SHs7PFHO+wgpc1Gmhd9f9 DXCQM3uelsfvt6lsjuimw5i6wvu/xebszlimdj7mktfk7qjjot/uIDYrPOw9DLspFMC3oLowi2BcAGxWdth6Q0+804jdx1ycckwgxezj2hpy+otd0lymxjnxccbcqmzuclr6uYPYp269MPuHWQriA2KzbsPwx1Eq57Dpl42XJKtxyCBcQm7UalhfjLJbOk7NMShYJtyLCBcRmfYZlhCEx1u0g9/7SKKK2RBBZUYQLIM2ADMS4LZ8O9CTCXS9HX68QE4RBF+ECYRMO3L2V8B2MTSCTUPWC7C0WGXEZUWH5CPYQZMURJBUNRLICWEL3Z/CJR0VLRPV8FZPR9UU8ILWMCCRDAWGUEQHVHZLO4GABOL9XSCHCQAO2FM03HAGGGVXEL3Z Czkvxaalqxbjafcwia9slnpnabadbeunkuliaa2gs3m8ifbeb74wztuiaac/cbho5ha6hwxhvaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaacgsf8BAJz/gphzokqaaaasuvork5cyii=

Lee Mac 发表于 2022-7-5 13:47:45

以下情况可能会更好：

(defun c:tfit ( / ln pl pt tx )
   (if
       (and
         (setq tx (LM:selectifobject "\nSelect text: " "TEXT"))
         (setq pl (LM:selectifobject "\nSelect polyline: " "LWPOLYLINE"))
         (setq pl (mapcar 'cdr (vl-remove-if-not '(lambda ( x ) (= 10 (car x))) (entget pl)))
               pl (mapcar '(lambda ( x ) (apply 'mapcar (cons x pl))) '(min max))
               tx (entgettx)
               tb (textbox tx)
               vc (mapcar '- (avgpt pl) (mapcar '+ (cdr (assoc 10 tx)) (avgpt tb)))
         )
       )
       (entmod
         (subst '(72 . 1) (assoc 72 tx)
               (subst '(73 . 2) (assoc 73 tx)
                   (subst (cons 11 (mapcar '+ (cdr (assoc 11 tx)) vc)) (assoc 11 tx)
                     (subst
                           (cons 40
                               (*(cdr (assoc 40 tx)) 0.9 ;; Alter this to suit
                                 (apply 'min
                                       (mapcar '/
                                           (apply 'mapcar (cons '- (reverse pl)))
                                           (apply 'mapcar (cons '- (reverse (textbox tx))))
                                       )
                                 )
                               )
                           )
                           (assoc 40 tx) tx
                     )
                   )
               )
         )
       )
   )
   (princ)
)

(defun avgpt ( lst )
   ((lambda ( len ) (mapcar '/ (apply 'mapcar (cons '+ lst)) (list len len))) (length lst))
)
   
;; Select if Object-Lee Mac
;; Continuously prompts the user for a selection of a specific object

(defun LM:selectifobject ( msg obj / ent )
   (while
       (progn (setvar 'errno 0) (setq ent (car (entsel msg)))
         (cond
               (   (= 7 (getvar 'errno))
                   (princ "\nMissed, try again.")
               )
               (   (= 'ename (type ent))
                   (if (/= obj (cdr (assoc 0 (entget ent))))
                     (princ "\nInvalid Object Selected.")
                   )
               )
         )
       )
   )
   ent
)
(princ)

Lee Mac 发表于 2022-7-5 13:49:43

更新后的程序还好吗？
页: [1] 2
查看完整版本: 文字拟合lisp