单行文本动态拉伸

start4444

尘缘一生

程序修改下：增加改后变色，增加垂直书写判断合理调节。

1. ;;; -----------------------------------
   
2. ;;; 单行文本动态拉伸 by：langjs
   
3. ;;; -----修改：白领坛主------------------------------
   
4. (defun c:qq (/ box data ent gr h hb hh loop p ss w wb ang)
   
5.   (defun emod (h w ent)
   
6.     (entmod (subst
   
7.               (cons h w)
   
8.               (assoc h ent)
   
9.               ent
   
10.             )
    
11.     )
    
12.   )
    
13.   (if (setq ss (ssget ":E:S" '((0 . "TEXT"))))
    
14.     (progn
    
15.       (setq ent (entget (ssname ss 0))
    
16.         p (cdr (assoc 10 ent))
    
17.         h (cdr (assoc 40 ent))
    
18.         w (cdr (assoc 41 ent))
    
19.         ang (cdr (assoc 50 ent))
    
20.         box (textbox (cdr ent))
    
21.         hb (/ (cadr (cadr box)) h)
    
22.         wb (/ (car (cadr box)) (* h w))
    
23.         loop t
    
24.       )   
    
25.       (princ "\n指定拉伸点:")
    
26.       (while loop
    
27.         (setq gr (grread t 15 0)
    
28.           data (cadr gr)
    
29.         )
    
30.         (cond
    
31.           ((= (car gr) 3)
    
32.             (setq loop nil)
    
33.           )
    
34.           ((= (car gr) 5)
    
35.             (if (/= 1 (sin ang))
    
36.               (progn
    
37.                 (setq hh (* hb (abs (- (cadr data) (cadr p))))
    
38.                   ent (emod 40 hh ent)
    
39.                 )
    
40.                 (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)
    
41.               )
    
42.             )
    
43.             (if (= 1 (sin ang))
    
44.               (progn
    
45.                 (setq hh (/ (* hb (abs (- (cadr data) (cadr p)))) 2)
    
46.                   ent (emod 40 hh ent)
    
47.                 )
    
48.                 (emod 41 (/ (abs (- (cadr data) (cadr p))) (* hh wb)) ent)
    
49.               )
    
50.             )            
    
51.           )
    
52.           ((member (car gr) '(11 25))
    
53.             (setq loop nil
    
54.               ent (emod 40 h ent)
    
55.             )
    
56.             (emod 41 w ent)
    
57.           )
    
58.         )
    
59.       )
    
60.     )
    
61.   )
    
62.   (setq oldlup (getvar "LUPREC"))
    
63.   (setvar "LUPREC" 0)           ; 精度到各位,以便后续取得标准颜色号
    
64.   (command "CHANGE" (ssname ss 0) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS")
    
65.                                                          8
    
66.                                                        )
    
67.                                                    )
    
68.                                              ) ""
    
69.   )
    
70.   (setvar "LUPREC" oldlup)         ; 恢复数值小数位数
    
71.   (princ)
    
72. )
    

;;; -----------------------------------<br /> ;;; 单行文本动态拉伸 by：langjs<br /> ;;; -----修改：白领坛主------------------------------<br /> (defun c:qq (/ box data ent gr h hb hh loop p ss w wb ang)<br />   (defun emod (h w ent)<br />     (entmod (subst<br />               (cons h w)<br />               (assoc h ent)<br />               ent<br />             )<br />     )<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 />         ang (cdr (assoc 50 ent))<br />         box (textbox (cdr ent))<br />         hb (/ (cadr (cadr box)) h)<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)<br />             (setq loop nil)<br />           )<br />           ((= (car gr) 5)<br />             (if (/= 1 (sin ang))<br />               (progn<br />                 (setq hh (* hb (abs (- (cadr data) (cadr p))))<br />                   ent (emod 40 hh ent)<br />                 )<br />                 (emod 41 (/ (abs (- (car data) (car p))) (* hh wb)) ent)<br />               )<br />             )<br />             (if (= 1 (sin ang))<br />               (progn<br />                 (setq hh (/ (* hb (abs (- (cadr data) (cadr p)))) 2)<br />                   ent (emod 40 hh ent)<br />                 )<br />                 (emod 41 (/ (abs (- (cadr data) (cadr p))) (* hh wb)) ent)<br />               )<br />             )            <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 />   (setq oldlup (getvar "LUPREC"))<br />   (setvar "LUPREC" 0)           ; 精度到各位,以便后续取得标准颜色号<br />   (command "CHANGE" (ssname ss 0) "" "P" "C" (rtos (1+ (rem (getvar "CPUTICKS")<br />                                                          8<br />                                                        )<br />                                                    )<br />                                              ) ""<br />   )<br />   (setvar "LUPREC" oldlup)         ; 恢复数值小数位数<br />   (princ)<br /> )<br />

taoyi0727

不错的楼主，谢谢分享啊。

qssq

请问怎样修改能固定字高，仅仅拉伸宽度?

yoyoho

不错的楼主，谢谢分享!!!!!

ketxu

This not catch case  (divide by zero)

zhaozwf

这个不错，谢谢分享

ninja37

很好用啊 省的每次放大缩小  还大小控制不好  不错的楼主

ninja37

大师再放点干货出来啊

彳余

大师，能否支持块内或者块属性文字?