根据图框比例调整标注，支持标注-线型-填充-文字，对弧长标注无效，已解决
本帖最后由 andyzha 于 2022-8-27 09:28 编辑源码是SunSpring的原创，根据图框比例调整标注，支持标注、线型比例、填充、文字大小，原理是抓取图框比例，缩放标注的全局比例，文字大小是读取textsize参数，如果觉得调整后的文字太小，可调整参数textsize，默认2.5，可以设置成3.5即可
但是原程序对弧长标注dar无效，无法随之调整，求大神修复解决。
(setq *en2obj* vlax-ename->vla-object)
;;;图框位置
(defun titleplace (titlename p0 / entdata entgrp entname i n pb pc ptlist titlescale txdata)
(if (setq entgrp (ssget "x" (list '(0 . "insert") (cons 2 titlename))))
(repeat (setq n (sslength entgrp))
(setq entname (ssname entgrp (setq n (1- n))))
(setq titlescale (vla-get-XScaleFactor (*en2obj* entname)))
(setq ptlist (append (ax:getboundingbox entname) (list titlescale)))
(setq txdata (append (list ptlist) txdata))
)
)
(setq i 0)
(if (and p0 txdata)
(while (< i (length txdata))
(setq pb (nth 0 (nth i txdata)))
(setq pc (nth 1 (nth i txdata)))
(if (and
(> (nth 0 p0) (nth 0 pb))
(< (nth 0 p0) (nth 0 pc))
(> (nth 1 p0) (nth 1 pb))
(< (nth 1 p0) (nth 1 pc))
)
(progn
(setvar "dimscale" (nth 2 (nth i txdata)))
(setq i (length txdata))
)
(setvar "dimscale" 1.0)
)
(setq i (+ i 1))
)
)
)
;;;返回图元对象边框的最大和最小点
(defun ax:getboundingbox (entname / entpl entpr ptlist)
(vla-getboundingbox (vlax-ename->vla-object entname) 'entpl 'entpr)
(setq ptlist (mapcar 'vlax-safearray->list (list entpl entpr)))
(mapcar '(lambda (x) (trans x 0 1)) ptlist)
)
(defun getentdxf (ent dxf)
(cond
((= (type ent) 'ename)
(cdr (assoc dxf (entget ent '("*"))))
)
((= (type ent) 'vla-object)
(cdr (assoc dxf (entget (vlax-vla-object->ename ent) '("*"))))
)
)
)
;;;出错退出
(defun errexit (s)
(restore)
(princ)
)
;;;出错处理
(defun saverror ()
(setq olderr *error*)
(setq *error* errexit)
(setvar "cmdecho" 0)
(setq clayer (getvar "clayer"))
(setq lastent (entlast))
)
;;;出错恢复
(defun restore ()
(redraw)
(setq *error* olderr)
(setvar "clayer" clayer)
(princ)
)
;;;根据图框比例自动改变图框内所有对象全局比例
(defun c:ds ( / entdata entgrp entname n ptlist scale)
(prompt "根据图框比例自动改变图框内所有标注全局比例")
(saverror)
(if (setq entname (entsel))
(if (= "INSERT" (cdr (assoc 0 (entget (car entname)))))
(progn
(setq ptlist (ax:getboundingbox (car entname)))
(command "zoom" (car ptlist) (cadr ptlist))
(setq entgrp (ssget "W" (car ptlist) (cadr ptlist) '((0 . "DIMENSION,ARC_DIMENSION,*TEXT,*LINE,HATCH,LEADER,ACMSURFSYM,ACMWELDSYM"))))
(setq scale (vla-get-XScaleFactor (*en2obj* (car entname))))
(repeat (setq n (sslength entgrp))
(setq entname (ssname entgrp (setq n (1- n))))
(cond
((= "HATCH" (getentdxf entname 0))
(vla-put-PatternScale (*en2obj* entname) scale)
)
((= "DIMENSION" (getentdxf entname 0))
(vla-put-ScaleFactor (*en2obj* entname) scale)
)
((= "ARC_DIMENSION" (getentdxf entname 0))
(vla-put-ScaleFactor (*en2obj* entname) scale)
)
((wcmatch (getentdxf entname 0) "*TEXT")
(vla-put-Height (*en2obj* entname) (* (getvar "textsize") scale))
)
((wcmatch (getentdxf entname 0) "*LINE")
(vla-put-LinetypeScale (*en2obj* entname) scale)
)
((wcmatch (getentdxf entname 0) "LEADER")
(vla-put-ScaleFactor (*en2obj* entname) scale)
)
((wcmatch (getentdxf entname 0) "ACMSURFSYM,ACMWELDSYM")
(setq entdata (entget entname))
(setq entdata (subst (cons 40 scale) (assoc 40 entdata) entdata))
(entmod entdata)
)
)
)
)
)
)
(restore)
(princ)
)
感谢lostbalance的点拨，顿时豁然开朗。已修改，支持调整弧长标注了。
弧长的0码是ARC_DIMENSION，你的程序里都没加 个人理解，是不是弧长标注需要特殊参数控制所以没被调整过来？
能不能把特定的块也加进去？比如‘索引号’ lostbalance 发表于 2022-8-25 10:13
弧长的0码是ARC_DIMENSION，你的程序里都没加
感谢提醒，按你的提示成功修改完善了，ps：一激动，给你点上反对了:lol 感谢分享，给个赞。 谢谢分享。能用到，支持 感谢分享~已经用上了~
请教下楼主
文字太小，可调整参数textsize，默认2.5
((wcmatch (getentdxf entname 0) "*TEXT")
(vla-put-Height (*en2obj* entname) (* (getvar "textsize") scale))
是不是改第一行的数字0....
适合一个文件有多张图纸的标注调整~
赞一下~
台湾网站找到一个：
https://www.autocad-tw.com/t17999-topic 本帖最后由 huxu823 于 2024-4-17 22:24 编辑
这程序怎么使用啊？加载后，选择图框没反应，选择标注也没反应，全选还是没反应。
图框比例这个数据是怎么读取的，对图框有什么要求？
页:
[1]
2