[日积月累]：每次比例输入很麻烦，我想把修改高宽比固定为0.7，请指教.

ln2127105

每次比例输入很麻烦，我想把修改高宽比固定为0.7，请指教.

2. 
   
3. (defun C:chhw();/ test ss len n en1 a oldr newr ent oldf nn)
   
4.   (setvar "CMDECHO" 0)
   
5.   (setq test T nn 0)
   
6.   (while test
   
7.     (setq ss (ssadd))
   
8.     (setq ss (ssget))
   
9.     (if (= nil ss)
   
10.       (setq test nil)
    
11.       (progn
    
12.         (setq len (sslength ss))
    
13.         (setq n 1 s 1)
    
14.         (while (<= n len)
    
15.           (setq en1 (ssname ss (1- n)))
    
16.           (setq a (entget en1))
    
17.           (if  (= "TEXT" (cdr (assoc 0 a)))
    
18.             (progn
    
19.               (if (= s 1)
    
20.                 (progn
    
21.                   (setq oldr (cdr (assoc 41 a)))
    
22.                   (setq newr (getreal (strcat "\nNew width:high <" (rtos oldr 2 2) ">:")))
    
23.                   (if (= newr nil) (setq newr oldr))
    
24.                   (setq s nil)
    
25.                 )
    
26.               )
    
27.               (setq ent (subst (cons 41 newr) (assoc 41 a) a))
    
28.               (setq ent (subst (cons 72 0) (assoc 72 ent) ent))
    
29.               (entmod ent)
    
30.               (setq nn (1+ nn))
    
31.             )
    
32.           )
    
33.           (setq n (1+ n))
    
34.         )
    
35.       )
    
36.     )
    
37.   )
    
38.   (princ (strcat (itoa nn) " changed !"))
    
39.   (princ)
    
40. )

<br /> (defun C:chhw();/ test ss len n en1 a oldr newr ent oldf nn)<br />   (setvar "CMDECHO" 0)<br />   (setq test T nn 0)<br />   (while test<br />     (setq ss (ssadd))<br />     (setq ss (ssget))<br />     (if (= nil ss)<br />       (setq test nil)<br />       (progn<br />         (setq len (sslength ss))<br />         (setq n 1 s 1)<br />         (while (<= n len)<br />           (setq en1 (ssname ss (1- n)))<br />           (setq a (entget en1))<br />           (if  (= "TEXT" (cdr (assoc 0 a)))<br />             (progn<br />               (if (= s 1)<br />                 (progn<br />                   (setq oldr (cdr (assoc 41 a)))<br />                   (setq newr (getreal (strcat "\nNew width:high <" (rtos oldr 2 2) ">:")))<br />                   (if (= newr nil) (setq newr oldr))<br />                   (setq s nil)<br />                 )<br />               )<br />               (setq ent (subst (cons 41 newr) (assoc 41 a) a))<br />               (setq ent (subst (cons 72 0) (assoc 72 ent) ent))<br />               (entmod ent)<br />               (setq nn (1+ nn))<br />             )<br />           )<br />           (setq n (1+ n))<br />         )<br />       )<br />     )<br />   )<br />   (princ (strcat (itoa nn) " changed !"))<br />   (princ)<br /> )

xyp1964

[php](load "xyp_lib");加载通用函数
;|
如果已经下载xyp_lib并放到搜索路径下可以不再下载!
利用以下任何一种方式即可加载和运行通用函数内的所有子程序：
1.在acad.lsp中增加(load"xyp_lib")
2.在每个程序内增加(load"xyp_lib")
3.在command下，输入(load"xyp_lib")
4.在菜单.mnl中增加(load"xyp_lib")
通用函数下载地址：http://www.xdcad.net/forum/showthread.php?s=&threadid=325268
|;

;;;;;;;;;;;;;;;;;;;;;;;;;
;;;* 改换字宽------------
;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFUN C:GHZK ()
  (cmdla0)
  (princ "\n选择文本: ")
  (while (not (SETQ ss (ssget (LIST (cons 0 "text"))))))
  (setq        n  -1
        s1 (ssname ss 0)
  )
  (princ "\n旧宽度因子为 ")
  (princ (dxf 41 (entget S1)))
  (setq th (ureal 1 "" "\n新宽度因子为 " th))
  (princ "\n稍候")
  (princ)
  (while (setq s1 (ssname ss (setq n (1+ n))))
    (princ ".")
    (sub_upd s1 41 th)
  )
  (princ "OK!")
  (cmdla1)
)
(Princ "GHZK  (改换字宽)")
(princ)
[/php]

firstintimate

这样还不如直接在文字样式里指定

它山之石

[php]
(defun C:chhw (/ test ss len n en1 a oldr newr ent oldf nn)
  (setvar "CMDECHO" 0)
  (setq        test T
        nn 0
  )
  (while test
    (setq ss (ssadd))
    (setq ss (ssget))
    (if        (= nil ss)
      (setq test nil)
      (progn
        (setq len (sslength ss))
        (setq n        1
              s        1
        )
        (while (<= n len)
          (setq en1 (ssname ss (1- n)))
          (setq a (entget en1))
          (if (= "TEXT" (cdr (assoc 0 a)))
            (progn
              (if (= s 1)
                (progn
                  (setq oldr (cdr (assoc 41 a)))
;;;(setq newr (getreal (strcat "\nNew width:high <" (rtos oldr 2 2) ">:")))
;;; (if (= newr nil) (setq newr oldr))
                  (setq newr 0.7)
                  (setq s nil)
                )
              )
              (setq ent (subst (cons 41 newr) (assoc 41 a) a))
              (setq ent (subst (cons 72 0) (assoc 72 ent) ent))
              (entmod ent)
              (setq nn (1+ nn))
            )
          )
          (setq n (1+ n))
        )
      )
    )
  )
  (princ (strcat (itoa nn) " changed !"))
  (princ)
)
[/php]

狂刀

[php]
(defun c:tt()
  (ssget '((0 . "TEXT")))
  (vlax-for x (vla-get-activeselectionset (vla-get-activedocument(vlax-get-acad-object)))
              (vla-put-ScaleFactor x 0.7)
  )(princ)
)
[/php]

eachy

1 楼主程序中的废话太多
2 ActiveSelectionset 可能有CURRENT BUG，使用ActiveX建议用Vlax-map-collection代替Vlax-for，后者仅在调试时使用。

2. 
   
3. (defun C:chhw (/ ss ssl e el)
   
4.   (if (setq ss (ssget '((0 . "Text") (-4 . "/=") (41 . 0.7))))
   
5.     (progn
   
6.       (setq ssl (sslength ss))
   
7.       (while (> ssl 0)
   
8.         (setq e         (ssname ss (setq ssl (1- ssl)))
   
9.               el (entget e)
   
10.         )
    
11.         (entmod (subst '(41 . 0.7) (assoc 41 el) el))
    
12.       )
    
13.     )
    
14.   )
    
15.   (princ)
    
16. )
    

<br /> (defun C:chhw (/ ss ssl e el)<br />   (if (setq ss (ssget '((0 . "Text") (-4 . "/=") (41 . 0.7))))<br />     (progn<br />       (setq ssl (sslength ss))<br />       (while (> ssl 0)<br />         (setq e         (ssname ss (setq ssl (1- ssl)))<br />               el (entget e)<br />         )<br />         (entmod (subst '(41 . 0.7) (assoc 41 el) el))<br />       )<br />     )<br />   )<br />   (princ)<br /> )<br />

啵浪鼓

能否将带属性block的文字宽度也一并设置字宽？

以上仅适用公司带属性的图框，可能图框内某个字体超出方格，所以需要将超出的文字单独改成适合的文字宽度

程序应提供一个输入宽度值，然后点选需要改变的block里的文字，执行时将所有相同的block全部改成将的宽度值

eachy

你应该首先修改图框文件

啵浪鼓

如果可以，也不至于发7楼的贴了

binggege1

2004的scaletext应该可以满足的要求吧？