CAD标注文字字高任意比例缩放

848818376

CAD标注文字字高任意比例缩放

劳烦大侠帮忙开发个LISP程序：“CAD标注文字字高任意比例缩放”也就是在标注时若觉得标注文字太大或太小可以用快捷键快速的把标注文字字高成一定比例缩放（如2，2.1，0.4等），这样使打印出来的图形美观、清楚，而不用去设置多个标注样式那么麻烦，关建是有时零件过小或过大时这几个标注样式还不适用，还得重建，相信大家也有遇到这情况吧？感谢！效果如下图


已解决，源码在5楼，感谢wowan1314 的帮助

664571221

Gu_xl 发表于 2012-12-14 15:39

你好G版本 能不能加一个图层 选择   和范围选择

664571221

Gu_xl 发表于 2012-12-14 15:39

你好G版本 能不能加一个图层 选择   和范围选择

wo870711

谢谢谢谢谢谢谢谢谢

wowan1314

组码里还没文字高度。
又找了半天VL函数才搞出来。。。。

848818376

wowan1314 发表于 2012-12-14 13:54
组码里还没文字高度。
又找了半天VL函数才搞出来。。。。

请问大侠，标注箭头有一起缩放吗？如果有就太好了！

848818376

848818376 发表于 2012-12-14 14:15
请问大侠，标注箭头有一起缩放吗？如果有就太好了！

好吧，虽然很穷没钱，我还是很愿意试试

wowan1314

试试.......网速真慢

848818376

wowan1314 发表于 2012-12-14 13:54
组码里还没文字高度。
又找了半天VL函数才搞出来。。。。

我试过了，不能把标注箭头一起缩放，希望能帮忙改下，还有个问题就是：第一次修改的比例在下次使用时能有记录，我这也有个lsp也是不能达到这两点：

(princ "\n修改标注的文字高度cq ")
(defun c:cq ()
(vl-load-com)
(setq k 0)
(initget 7)
(setq newh (getdist "\n请输入新字高:"))
(setq alldims (ssget  '((0 . "DIMENSION"))))
(while (< k (sslength alldims))
(setq dimvla (vlax-ename->vla-object (ssname alldims k)))
(vla-put-TextHeight dimvla newh)
(setq k (1+ k))
)
(princ)
)

848818376

848818376 发表于 2012-12-14 14:37
我试过了，不能把标注箭头一起缩放，希望能帮忙改下，还有个问题就是：第一次修改的比例在下次使用时能有 ...

是啊，谢谢

Gu_xl

1. ;;动态调整标注字高
   
2. (defun c:tt (/ ss n l gr loop)
   
3.   (while (setq ss (ssget '((0 . "DIMENSION"))))
   
4.     (setq l nil)
   
5.     (repeat (setq n (sslength ss))
   
6.       (setq l (cons (vlax-ename->vla-object (ssname ss (setq n (1- n)))) l))
   
7.       )
   
8.     (setq loop t)
   
9.     (princ "\n** 按键 \"+\" 增大字高 \"-\" 减小字高 回车间、鼠标左键结束")
   
10.     (while loop
    
11.       (setq gr (grread t 15))
    
12.       (cond
    
13.         ((= 3 (car gr))
    
14.          (setq loop nil)
    
15.          )
    
16.         ((= 2 (car gr))
    
17.          (cond
    
18.            ((or (= 13 (cadr gr)) (= 32 (cadr gr)))
    
19.             (setq loop nil)
    
20.             )
    
21.            ((= 43 (cadr gr)) ;_ +
    
22.             (mapcar
    
23.               '(lambda (o)
    
24.                  (vla-put-TextHeight o (* 1.1 (vla-get-TextHeight o)))
    
25.                  )
    
26.               l
    
27.               )
    
28.             )
    
29.            ((= 45 (cadr gr)) ;_ -
    
30.             (mapcar
    
31.               '(lambda (o)
    
32.                  (vla-put-TextHeight o (* 0.9 (vla-get-TextHeight o)))
    
33.                  )
    
34.               l
    
35.               )
    
36.             )
    
37.            )
    
38.          )
    
39.         )
    
40.       )
    
41.     )
    
42.     (princ)
    
43.   )
    

;;动态调整标注字高<br /> (defun c:tt (/ ss n l gr loop)<br />   (while (setq ss (ssget '((0 . "DIMENSION"))))<br />     (setq l nil)<br />     (repeat (setq n (sslength ss))<br />       (setq l (cons (vlax-ename->vla-object (ssname ss (setq n (1- n)))) l))<br />       )<br />     (setq loop t)<br />     (princ "\n** 按键 \"+\" 增大字高 \"-\" 减小字高 回车间、鼠标左键结束")<br />     (while loop<br />       (setq gr (grread t 15))<br />       (cond<br />         ((= 3 (car gr))<br />          (setq loop nil)<br />          )<br />         ((= 2 (car gr))<br />          (cond<br />            ((or (= 13 (cadr gr)) (= 32 (cadr gr)))<br />             (setq loop nil)<br />             )<br />            ((= 43 (cadr gr)) ;_ +<br />             (mapcar<br />               '(lambda (o)<br />                  (vla-put-TextHeight o (* 1.1 (vla-get-TextHeight o)))<br />                  )<br />               l<br />               )<br />             )<br />            ((= 45 (cadr gr)) ;_ -<br />             (mapcar<br />               '(lambda (o)<br />                  (vla-put-TextHeight o (* 0.9 (vla-get-TextHeight o)))<br />                  )<br />               l<br />               )<br />             )<br />            )<br />          )<br />         )<br />       )<br />     )<br />     (princ)<br />   )<br />

vlisp2012

G版，太给力了，多谢了！

梦里水香

Gu_xl 发表于 2012-12-14 15:39

太厉害了。。不知道文字动态了，标注的箭头太小怎么办？