希望帮改个文字拉伸代码

qssq

之前论坛有个单行文字拉伸程序挺好的，但是拉伸时会改变字高，哪位兄弟能帮我改成字高不变的情况下拉伸，谢谢!
http://bbs.mjtd.com/thread-175713-1-1.html

satan421

1. ;;; -----------------------------------
   
2. ;;; 单行文本动态拉伸 by：langjs
   
3. ;;; -----------------------------------
   
4. 
   
5. ;;只改一句即可
   
6. (defun C:qq (/ box data ent gr h hb hh loop p ss w wb)
   
7.   (defun emod (h w ent)
   
8.     (entmod (subst (cons h w) (assoc h ent) ent))
   
9.   )
   
10.   (if (setq ss (ssget ":E:S" '((0 . "TEXT"))))
    
11.     (progn
    
12.       (setq ent         (entget (ssname ss 0))
    
13.             p         (cdr (assoc 10 ent))
    
14.             h         (cdr (assoc 40 ent))
    
15.             w         (cdr (assoc 41 ent))
    
16.             box         (textbox (cdr ent))
    
17.             hb         (/ h (cadr (cadr box)))
    
18.             wb         (/ (car (cadr box)) (* h w))
    
19.             loop t
    
20.       )
    
21.       (princ "\n指定拉伸点:")
    
22.       (while loop
    
23.         (setq gr   (grread t 15 0)
    
24.               data (cadr gr)
    
25.         )
    
26.         (cond
    
27.           ((= (car gr) 3) (setq loop nil))
    
28.           ((= (car gr) 5)
    
29.            (setq hh  h;;此处修改
    
30.                  ent (emod 40 hh ent)
    
31.            )
    
32.            (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)
    
33.           )
    
34.           ((member (car gr) '(11 25))
    
35.            (setq loop nil
    
36.                  ent  (emod 40 h ent)
    
37.            )
    
38.            (emod 41 w ent)
    
39.           )
    
40.         )
    
41.       )
    
42.     )
    
43.   )
    
44.   (princ)
    
45. )
    

;;; -----------------------------------<br /> ;;; 单行文本动态拉伸 by：langjs<br /> ;;; -----------------------------------<br /> <br /> ;;只改一句即可<br /> (defun C:qq (/ box data ent gr h hb hh loop p ss w wb)<br />   (defun emod (h w ent)<br />     (entmod (subst (cons h w) (assoc h ent) ent))<br />   )<br />   (if (setq ss (ssget ":E:S" '((0 . "TEXT"))))<br />     (progn<br />       (setq ent         (entget (ssname ss 0))<br />             p         (cdr (assoc 10 ent))<br />             h         (cdr (assoc 40 ent))<br />             w         (cdr (assoc 41 ent))<br />             box         (textbox (cdr ent))<br />             hb         (/ h (cadr (cadr box)))<br />             wb         (/ (car (cadr box)) (* h w))<br />             loop t<br />       )<br />       (princ "\n指定拉伸点:")<br />       (while loop<br />         (setq gr   (grread t 15 0)<br />               data (cadr gr)<br />         )<br />         (cond<br />           ((= (car gr) 3) (setq loop nil))<br />           ((= (car gr) 5)<br />            (setq hh  h;;此处修改<br />                  ent (emod 40 hh ent)<br />            )<br />            (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)<br />           )<br />           ((member (car gr) '(11 25))<br />            (setq loop nil<br />                  ent  (emod 40 h ent)<br />            )<br />            (emod 41 w ent)<br />           )<br />         )<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

qssq

satan421 发表于 2019-11-14 16:57

谢谢，您的回答完美的解决了这个问题，原程序选择文字采用单击选择，能否增加一个框选文字功能，就像CAD的拉伸命令那样直接框选。

satan421

qssq 发表于 2019-11-15 09:08
谢谢，您的回答完美的解决了这个问题，原程序选择文字采用单击选择，能否增加一个框选文字功能，就像CAD ...

可以框选改宽度比例，但是框选后动态拉伸比较难。