设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 根据图框比例调整标注，支持标注-线型-填充-文字，对弧 ...
12下一页
返回列表 发新帖
查看: 2287|回复: 11

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

[复制链接]
andyzha
发表于 2022-8-24 13:50:03 | 显示全部楼层 |阅读模式
本帖最后由 andyzha 于 2022-8-27 09:28 编辑

源码是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. )

  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. )



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

使用道具 举报

lostbalance
发表于 2022-8-25 10:13:13 | 显示全部楼层
弧长的0码是ARC_DIMENSION，你的程序里都没加

点评

andyzha
点拨一下，豁然开朗  发表于 2022-8-26 08:47
回复 支持 1 反对 1

使用道具 举报

andyzha
 楼主| 发表于 2022-8-25 08:28:44 | 显示全部楼层
个人理解，是不是弧长标注需要特殊参数控制所以没被调整过来？
回复 支持 反对

使用道具 举报

bai2000
发表于 2022-8-25 10:24:11 | 显示全部楼层
能不能把特定的块也加进去？比如‘索引号’
回复 支持 反对

使用道具 举报

andyzha
 楼主| 发表于 2022-8-26 08:46:25 | 显示全部楼层
lostbalance 发表于 2022-8-25 10:13
弧长的0码是ARC_DIMENSION，你的程序里都没加

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

使用道具 举报

Noangler
发表于 2023-3-24 13:10:11 | 显示全部楼层
感谢分享，给个赞。
回复 支持 反对

使用道具 举报

兰同学
发表于 2023-12-11 06:54:30 来自手机 | 显示全部楼层
谢谢分享。能用到，支持
回复 支持 反对

使用道具 举报

zhangrunze
发表于 2024-4-16 16:41:03 | 显示全部楼层
感谢分享~已经用上了~
请教下楼主
文字太小，可调整参数textsize，默认2.5

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

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

回复 支持 反对

使用道具 举报

zhangrunze
发表于 2024-4-16 16:45:29 | 显示全部楼层
适合一个文件有多张图纸的标注调整~
赞一下~
台湾网站找到一个：
https://www.autocad-tw.com/t17999-topic
回复 支持 反对

使用道具 举报

huxu823
发表于 2024-4-17 22:19:36 | 显示全部楼层
本帖最后由 huxu823 于 2024-4-17 22:24 编辑

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

使用道具 举报

12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-25 19:49 , Processed in 0.192554 second(s), 26 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表