根据图框比例调整标注，支持标注-线型-填充-文字，对弧长标注无效，已解决

andyzha

源码是SunSpring的原创，根据图框比例调整标注，支持标注、线型比例、填充、文字大小，原理是抓取图框比例，缩放标注的全局比例，文字大小是读取textsize参数，如果觉得调整后的文字太小，可调整参数textsize，默认2.5，可以设置成3.5即可
但是原程序对弧长标注dar无效，无法随之调整，求大神修复解决。

2. (setq *en2obj* vlax-ename->vla-object)
   
3. ;;;图框位置
   
4. (defun titleplace (titlename p0 / entdata entgrp entname i n pb pc ptlist titlescale txdata)
   
5.   (if (setq entgrp (ssget "x" (list '(0 . "insert") (cons 2 titlename))))
   
6.     (repeat (setq n (sslength entgrp))
   
7.       (setq entname (ssname entgrp (setq n (1- n))))
   
8.       (setq titlescale (vla-get-XScaleFactor (*en2obj* entname)))
   
9.       (setq ptlist (append (ax:getboundingbox entname) (list titlescale)))
   
10.       (setq txdata (append (list ptlist) txdata))
    
11.     )
    
12.   )
    
13.   (setq i 0)
    
14.   (if (and p0 txdata)
    
15.     (while (< i (length txdata))
    
16.       (setq pb (nth 0 (nth i txdata)))
    
17.       (setq pc (nth 1 (nth i txdata)))
    
18.       (if (and
    
19.       (> (nth 0 p0) (nth 0 pb))
    
20.       (< (nth 0 p0) (nth 0 pc))
    
21.       (> (nth 1 p0) (nth 1 pb))
    
22.       (< (nth 1 p0) (nth 1 pc))
    
23.     )
    
24.   (progn
    
25.     (setvar "dimscale" (nth 2 (nth i txdata)))
    
26.     (setq i (length txdata))
    
27.   )
    
28.   (setvar "dimscale" 1.0)
    
29.       )
    
30.       (setq i (+ i 1))
    
31.     )
    
32.   )
    
33. )
    
34. ;;;返回图元对象边框的最大和最小点
    
35. (defun ax:getboundingbox (entname / entpl entpr ptlist)
    
36.   (vla-getboundingbox (vlax-ename->vla-object entname) 'entpl 'entpr)
    
37.   (setq ptlist (mapcar 'vlax-safearray->list (list entpl entpr)))
    
38.   (mapcar '(lambda (x) (trans x 0 1)) ptlist)
    
39. )
    
40. (defun getentdxf (ent dxf)
    
41.   (cond
    
42.     ((= (type ent) 'ename)
    
43.       (cdr (assoc dxf (entget ent '("*"))))
    
44.     )
    
45.     ((= (type ent) 'vla-object)
    
46.       (cdr (assoc dxf (entget (vlax-vla-object->ename ent) '("*"))))
    
47.     )
    
48.   )
    
49. )
    
50. 
    
51. ;;;出错退出
    
52. (defun errexit (s)
    
53.   (restore)
    
54.   (princ)
    
55. )
    
56. ;;;出错处理
    
57. (defun saverror ()
    
58.   (setq olderr *error*)
    
59.   (setq *error* errexit)
    
60.   (setvar "cmdecho" 0)
    
61.   (setq clayer (getvar "clayer"))
    
62.   (setq lastent (entlast))
    
63. )
    
64. ;;;出错恢复
    
65. (defun restore ()
    
66.   (redraw)
    
67.   (setq *error* olderr)
    
68.   (setvar "clayer" clayer)
    
69.   (princ)
    
70. )
    
71. ;;;根据图框比例自动改变图框内所有对象全局比例
    
72. (defun c:ds ( / entdata entgrp entname n ptlist scale)
    
73.   (prompt "根据图框比例自动改变图框内所有标注全局比例")
    
74.   (saverror)
    
75.   (if (setq entname (entsel))
    
76.     (if (= "INSERT" (cdr (assoc 0 (entget (car entname)))))
    
77.       (progn
    
78.   (setq ptlist (ax:getboundingbox (car entname)))
    
79.   (command "zoom" (car ptlist) (cadr ptlist))
    
80.   (setq entgrp (ssget "W" (car ptlist) (cadr ptlist) '((0 . "DIMENSION,ARC_DIMENSION,*TEXT,*LINE,HATCH,LEADER,ACMSURFSYM,ACMWELDSYM"))))
    
81.   (setq scale (vla-get-XScaleFactor (*en2obj* (car entname))))
    
82.   (repeat (setq n (sslength entgrp))
    
83.     (setq entname (ssname entgrp (setq n (1- n))))
    
84.     (cond
    
85.       ((= "HATCH" (getentdxf entname 0))
    
86.         (vla-put-PatternScale (*en2obj* entname) scale)
    
87.       )
    
88.       ((= "DIMENSION" (getentdxf entname 0))
    
89.         (vla-put-ScaleFactor (*en2obj* entname) scale)
    
90.       )
    
91.       ((= "ARC_DIMENSION" (getentdxf entname 0))
    
92.         (vla-put-ScaleFactor (*en2obj* entname) scale)
    
93.       )
    
94.       ((wcmatch (getentdxf entname 0) "*TEXT")
    
95.         (vla-put-Height (*en2obj* entname) (* (getvar "textsize") scale))
    
96.       )
    
97.       ((wcmatch (getentdxf entname 0) "*LINE")
    
98.         (vla-put-LinetypeScale (*en2obj* entname) scale)
    
99.       )
    
100.       ((wcmatch (getentdxf entname 0) "LEADER")
     
101.         (vla-put-ScaleFactor (*en2obj* entname) scale)
     
102.       )
     
103.       ((wcmatch (getentdxf entname 0) "ACMSURFSYM,ACMWELDSYM")
     
104.         (setq entdata (entget entname))
     
105.         (setq entdata (subst (cons 40 scale) (assoc 40 entdata) entdata))
     
106.               (entmod entdata)
     
107.       )
     
108.     )
     
109.   )
     
110.       )
     
111.     )
     
112.   )
     
113.   (restore)
     
114.   (princ)
     
115. )

(setq *en2obj* vlax-ename->vla-object)<br /> ;;;图框位置<br /> (defun titleplace (titlename p0 / entdata entgrp entname i n pb pc ptlist titlescale txdata)<br />   (if (setq entgrp (ssget "x" (list '(0 . "insert") (cons 2 titlename))))<br />     (repeat (setq n (sslength entgrp))<br />       (setq entname (ssname entgrp (setq n (1- n))))<br />       (setq titlescale (vla-get-XScaleFactor (*en2obj* entname)))<br />       (setq ptlist (append (ax:getboundingbox entname) (list titlescale)))<br />       (setq txdata (append (list ptlist) txdata))<br />     )<br />   )<br />   (setq i 0)<br />   (if (and p0 txdata)<br />     (while (< i (length txdata))<br />       (setq pb (nth 0 (nth i txdata)))<br />       (setq pc (nth 1 (nth i txdata)))<br />       (if (and<br />       (> (nth 0 p0) (nth 0 pb))<br />       (< (nth 0 p0) (nth 0 pc))<br />       (> (nth 1 p0) (nth 1 pb))<br />       (< (nth 1 p0) (nth 1 pc))<br />     )<br />   (progn<br />     (setvar "dimscale" (nth 2 (nth i txdata)))<br />     (setq i (length txdata))<br />   )<br />   (setvar "dimscale" 1.0)<br />       )<br />       (setq i (+ i 1))<br />     )<br />   )<br /> )<br /> ;;;返回图元对象边框的最大和最小点<br /> (defun ax:getboundingbox (entname / entpl entpr ptlist)<br />   (vla-getboundingbox (vlax-ename->vla-object entname) 'entpl 'entpr)<br />   (setq ptlist (mapcar 'vlax-safearray->list (list entpl entpr)))<br />   (mapcar '(lambda (x) (trans x 0 1)) ptlist)<br /> )<br /> (defun getentdxf (ent dxf)<br />   (cond<br />     ((= (type ent) 'ename)<br />       (cdr (assoc dxf (entget ent '("*"))))<br />     )<br />     ((= (type ent) 'vla-object)<br />       (cdr (assoc dxf (entget (vlax-vla-object->ename ent) '("*"))))<br />     )<br />   )<br /> )<br /> <br /> ;;;出错退出<br /> (defun errexit (s)<br />   (restore)<br />   (princ)<br /> )<br /> ;;;出错处理<br /> (defun saverror ()<br />   (setq olderr *error*)<br />   (setq *error* errexit)<br />   (setvar "cmdecho" 0)<br />   (setq clayer (getvar "clayer"))<br />   (setq lastent (entlast))<br /> )<br /> ;;;出错恢复<br /> (defun restore ()<br />   (redraw)<br />   (setq *error* olderr)<br />   (setvar "clayer" clayer)<br />   (princ)<br /> )<br /> ;;;根据图框比例自动改变图框内所有对象全局比例<br /> (defun c:ds ( / entdata entgrp entname n ptlist scale)<br />   (prompt "根据图框比例自动改变图框内所有标注全局比例")<br />   (saverror)<br />   (if (setq entname (entsel))<br />     (if (= "INSERT" (cdr (assoc 0 (entget (car entname)))))<br />       (progn<br />   (setq ptlist (ax:getboundingbox (car entname)))<br />   (command "zoom" (car ptlist) (cadr ptlist))<br />   (setq entgrp (ssget "W" (car ptlist) (cadr ptlist) '((0 . "DIMENSION,ARC_DIMENSION,*TEXT,*LINE,HATCH,LEADER,ACMSURFSYM,ACMWELDSYM"))))<br />   (setq scale (vla-get-XScaleFactor (*en2obj* (car entname))))<br />   (repeat (setq n (sslength entgrp))<br />     (setq entname (ssname entgrp (setq n (1- n))))<br />     (cond<br />       ((= "HATCH" (getentdxf entname 0))<br />         (vla-put-PatternScale (*en2obj* entname) scale)<br />       )<br />       ((= "DIMENSION" (getentdxf entname 0))<br />         (vla-put-ScaleFactor (*en2obj* entname) scale)<br />       )<br />       ((= "ARC_DIMENSION" (getentdxf entname 0))<br />         (vla-put-ScaleFactor (*en2obj* entname) scale)<br />       )<br />       ((wcmatch (getentdxf entname 0) "*TEXT")<br />         (vla-put-Height (*en2obj* entname) (* (getvar "textsize") scale))<br />       )<br />       ((wcmatch (getentdxf entname 0) "*LINE")<br />         (vla-put-LinetypeScale (*en2obj* entname) scale)<br />       )<br />       ((wcmatch (getentdxf entname 0) "LEADER")<br />         (vla-put-ScaleFactor (*en2obj* entname) scale)<br />       )<br />       ((wcmatch (getentdxf entname 0) "ACMSURFSYM,ACMWELDSYM")<br />         (setq entdata (entget entname))<br />         (setq entdata (subst (cons 40 scale) (assoc 40 entdata) entdata))<br />               (entmod entdata)<br />       )<br />     )<br />   )<br />       )<br />     )<br />   )<br />   (restore)<br />   (princ)<br /> )

感谢lostbalance的点拨，顿时豁然开朗。已修改，支持调整弧长标注了。

lostbalance

弧长的0码是ARC_DIMENSION，你的程序里都没加

andyzha

个人理解，是不是弧长标注需要特殊参数控制所以没被调整过来？

bai2000

能不能把特定的块也加进去？比如‘索引号’

andyzha

lostbalance 发表于 2022-8-25 10:13
弧长的0码是ARC_DIMENSION，你的程序里都没加

感谢提醒，按你的提示成功修改完善了，ps：一激动，给你点上反对了

Noangler

感谢分享，给个赞。

兰同学

谢谢分享。能用到，支持

zhangrunze

感谢分享~已经用上了~
请教下楼主
文字太小，可调整参数textsize，默认2.5

      ((wcmatch (getentdxf entname 0) "*TEXT")
        (vla-put-Height (*en2obj* entname) (* (getvar "textsize") scale))

是不是改第一行的数字0....

zhangrunze

适合一个文件有多张图纸的标注调整~
赞一下~
台湾网站找到一个：
https://www.autocad-tw.com/t17999-topic

huxu823

这程序怎么使用啊？加载后，选择图框没反应，选择标注也没反应，全选还是没反应。
图框比例这个数据是怎么读取的，对图框有什么要求？