明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 43664|回复: 138

标注整理v2.0源程序

    [复制链接]
发表于 2011-11-25 23:08:02 | 显示全部楼层 |阅读模式
本帖最后由 langjs 于 2012-1-15 20:30 编辑

《标注整理》v2.0
功能:水平标注和垂直标注整理成等距离格式
命令:ZL
使用:输入命令Zl,把一个视图连同标注选全上,程序会自动计算视图的范围,把标注沿视图的四个方向拉伸。

2.0虽然比1.0操作起来简单,但是效果不一定合适,呵呵,献丑了
根据不同的使用情况进行了更新《标注整理》v4.0/4.1在38楼和44楼




  1. ;;;          《标注整理》v2.0
  2. ;;; ============================================
  3. ;;; 功能:水平标注和垂直标注整理成等距离格式
  4. ;;; 使用:输入命令Zl,把一个视图连同标注选全
  5. ;;; 作者:langjs qq:59509100 日期:2011年11月25日
  6. ;;; ============================================
  7. (defun C:ZL (/ bili end end_data ent i maxp maxx maxx0 maxy maxy0 minp minx minx0 miny miny0 name p10 p10x p10y p13 p13x p13y p14
  8.         p14x p14y pan pany pmax pmin ss ss00 ss01 ss02 ss03 ss04 zhigao
  9.      )
  10.   (vl-load-com)
  11.   (setvar "cmdecho" 0)
  12.   (command ".UNDO" "BE")
  13.   (setq ss00 (ssget '((0 . "DIMENSION,LINE,LWPOLYLINE"))))
  14.   (setq zhigao (getvar "DIMTXT")
  15. pan (getvar "DIMGAP")
  16. bili (getvar "DIMSCALE")
  17.   )
  18.   (setq pany (* (+ zhigao pan) bili 1.5)) ; 此处设置“默认尺寸间距”为字高加偏移的1.5倍
  19.   (setq ss (ssadd)
  20. ss01 (ssadd)
  21. ss02 (ssadd)
  22. ss03 (ssadd)
  23. ss04 (ssadd)
  24.   )
  25.   (repeat (setq i (sslength ss00))
  26.     (setq name (ssname ss00 (setq i (1- i))))
  27.     (if (= (cdr (assoc 0 (entget name))) "DIMENSION")
  28.       (progn
  29. (setq ent (entget name))
  30. (setq p10 (cdr (assoc 10 ent))
  31.        p13 (cdr (assoc 13 ent))
  32.        p14 (cdr (assoc 14 ent))
  33. )
  34. (setq p10x (car p10)
  35.        p10y (cadr p10)
  36.        p13x (car p13)
  37.        p13y (cadr p13)
  38.        p14x (car p14)
  39.        p14y (cadr p14)
  40. )
  41. (if (> (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
  42.    (setq ss01 (ssadd name ss01))
  43. )
  44. (if (> (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
  45.    (setq ss02 (ssadd name ss02))
  46. )
  47. (if (< (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
  48.    (setq ss03 (ssadd name ss03))
  49. )
  50. (if (< (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
  51.    (setq ss04 (ssadd name ss04))
  52. )
  53.       )
  54.       (setq ss (ssadd name ss))
  55.     )
  56.   )
  57.   (setq ss (Lguolv ss))
  58.   (setq minx0 1e6
  59. miny0 1e6
  60. maxx0 -1e6
  61. maxy0 -1e6
  62.   )
  63.   (setq i 0)
  64.   (repeat (sslength ss)
  65.     (setq end (ssname ss i))
  66.     (setq end_data (entget end))
  67.     (vla-getboundingbox (vlax-ename->vla-object end) 'minp 'maxp)
  68.     (setq minp (vlax-safearray->list minp)
  69.    maxp (vlax-safearray->list maxp)
  70.     )
  71.     (setq minx (car minp)
  72.    maxx (car maxp)
  73.    miny (cadr minp)
  74.    maxy (cadr maxp)
  75.     )
  76.     (if (> minx0 minx)
  77.       (setq minx0 minx)
  78.     )
  79.     (if (> miny0 miny)
  80.       (setq miny0 miny)
  81.     )
  82.     (if (< maxx0 maxx)
  83.       (setq maxx0 maxx)
  84.     )
  85.     (if (< maxy0 maxy)
  86.       (setq maxy0 maxy)
  87.     )
  88.     (setq i (1+ i))
  89.   )
  90.   (setq pmin (list minx0 miny0)
  91. pmax (list maxx0 maxy0)
  92.   )
  93.   (fenxiangxianbiaozhu ss01 pmax pany)
  94.   (fenxiangxianbiaozhu ss02 pmax pany)
  95.   (fenxiangxianbiaozhu ss03 pmin pany)
  96.   (fenxiangxianbiaozhu ss04 pmin pany)
  97.   (princ)
  98. )
  99. (defun fenxiangxianbiaozhu (ss p0 pany / ent hlst i lst name p10 p10x p10y p13 p13x p13y p14 p14x p14y uu vv)
  100.   (setq lst '()
  101. Hlst '()
  102.   )
  103.   (repeat (setq i (sslength ss))
  104.     (setq name (ssname ss (setq i (1- i))))
  105.     (setq ent (entget name))
  106.     (setq p10 (cdr (assoc 10 ent))
  107.    p13 (cdr (assoc 13 ent))
  108.    p14 (cdr (assoc 14 ent))
  109.     )
  110.     (setq p10x (car p10)
  111.    p10y (cadr p10)
  112.    p13x (car p13)
  113.    p13y (cadr p13)
  114.    p14x (car p14)
  115.    p14y (cadr p14)
  116.     )
  117.     (cond
  118.       ((= (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
  119. (if (< p13x p14x)
  120.    (setq lst (cons (list name p13x p14x) lst))
  121.    (setq lst (cons (list name p14x p13x) lst))
  122. )
  123.       )
  124.       ((= (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
  125. (if (< p13y p14y)
  126.    (setq Hlst (cons (list name p13y p14y) Hlst))
  127.    (setq Hlst (cons (list name p14y p13y) Hlst))
  128. )
  129.       )
  130.       (t
  131. (princ)
  132.       )
  133.     )
  134.   )
  135.   (setq uu 0
  136. vv 1
  137.   )
  138.   (biaozhu lst p0 uu vv pany)        ; 处理水平标注
  139.   (setq uu 1
  140. vv 0
  141.   )
  142.   (biaozhu Hlst p0 uu vv pany)        ; 处理垂直标注
  143.   (command ".UNDO" "E")
  144.   (princ)
  145. )
  146. ;;; 计算坐标点,尺寸更新到合适位置子函数
  147. (defun biaozhu (lst p0 uu vv pany / bili chansu dim1 ent fuh fuh1 i lst_p1314x lst_p1314x_bak lst_p1314y lst_p1314y_bak lst02 n name
  148.       p0x p0y p10 p10x p10y p11 p11x p11y p13 p13x p13y p14 p14x p14y pl pmax pmin
  149.         )
  150.   (setq n 1)
  151.   (setq bili (getvar "DIMSCALE")
  152. pl (getvar "dimexe")
  153. lst_p1314x_bak '()
  154. lst_p1314y_bak '()
  155.   )
  156.   (while (> (length lst) 0)
  157.     (setq i 0
  158.    p0x (car p0)
  159.    p0y (cadr p0)
  160.     )
  161.     (setq lst02 (lstbak lst))
  162.     (setq lst_p1314x '()
  163.    lst_p1314y '()
  164.     )
  165.     (while (< i (length lst))
  166.       (setq dim1 (nth i lst))
  167.       (setq i (1+ i))
  168.       (setq name (car dim1)
  169.      pmin (cadr dim1)
  170.      pmax (caddr dim1)
  171.       )
  172.       (setq chansu (baohan dim1 lst))
  173.       (if (or
  174.      (= chansu "F")
  175.      (= chansu "Y")
  176.    )
  177. (progn
  178.    (setq ent (entget name))
  179.    (setq p10 (cdr (assoc 10 ent))
  180.   p11 (cdr (assoc 11 ent))
  181.   p13 (cdr (assoc 13 ent))
  182.   p14 (cdr (assoc 14 ent))
  183.    )
  184.    (setq p10x (car p10)
  185.   p10y (cadr p10)
  186.   p11x (car p11)
  187.   p11y (cadr p11)
  188.   p13x (car p13)
  189.   p13y (cadr p13)
  190.   p14x (car p14)
  191.   p14y (cadr p14)
  192.    )
  193.    (if (> p10y p13y)
  194.      (setq fuh 1)
  195.      (setq fuh -1)
  196.    )
  197.    (if (> p10x p13x)
  198.      (setq fuh1 1)
  199.      (setq fuh1 -1)
  200.    )
  201.    (setq p10 (list (+ (* vv p10x) (* uu p0x) (* uu (* fuh1 (* n pany)))) (+ (* uu p10y) (* vv p0y) (* vv (* fuh (* n pany))))))
  202.    (setq p11 (list (+ (* vv p11x) (* uu p0x) (* uu (* fuh1 (* n pany)))) (+ (* uu p11y) (* vv p0y) (* vv (* fuh (* n pany))))))
  203.    (setq lst02 (vl-remove dim1 lst02))
  204.    (if (= chansu "Y")
  205.      (setq n (1+ n))
  206.    )
  207.    (if (= vv 1)
  208.      (progn
  209.        (if (member (sswr p13x 1) lst_p1314x_bak)
  210.   (setq p13 (list p13x (+ p0y (* fuh (* pl bili)) (* fuh (* (1- n) pany)))))
  211.        )
  212.        (if (member (sswr p14x 1) lst_p1314x_bak)
  213.   (setq p14 (list p14x (+ p0y (* fuh (* pl bili)) (* fuh (* (1- n) pany)))))
  214.        )
  215.      )
  216.    )
  217.    (setq lst_p1314x (cons (sswr p13x 1) lst_p1314x))
  218.    (setq lst_p1314x (cons (sswr p14x 1) lst_p1314x))
  219.    (setq lst_p1314x_bak (lstbak lst_p1314x))
  220.    (if (= vv 0)
  221.      (progn
  222.        (if (member (sswr p13y 1) lst_p1314y_bak)
  223.   (setq p13 (list (+ p0x (* fuh1 (* pl bili)) (* fuh1 (* (1- n) pany))) p13y))
  224.        )
  225.        (if (member (sswr p14y 1) lst_p1314y_bak)
  226.   (setq p14 (list (+ p0x (* fuh1 (* pl bili)) (* fuh1 (* (1- n) pany))) p14y))
  227.        )
  228.      )
  229.    )
  230.    (setq lst_p1314y (cons (sswr p13y 1) lst_p1314y))
  231.    (setq lst_p1314y (cons (sswr p14y 1) lst_p1314y))
  232.    (setq lst_p1314y_bak (lstbak lst_p1314y))
  233.    (setq ent (subst
  234.         (cons 10 p10)
  235.         (assoc 10 ent)
  236.         ent
  237.       )
  238.    )
  239.    (setq ent (subst
  240.         (cons 11 p11)
  241.         (assoc 11 ent)
  242.         ent
  243.       )
  244.    )
  245.    (setq ent (subst
  246.         (cons 13 p13)
  247.         (assoc 13 ent)
  248.         ent
  249.       )
  250.    )
  251.    (setq ent (subst
  252.         (cons 14 p14)
  253.         (assoc 14 ent)
  254.         ent
  255.       )
  256.    )
  257.    (entmod ent)
  258. )
  259.       )
  260.     )
  261.     (setq n (1+ n))
  262.     (setq lst lst02)
  263.   )
  264.   (princ)
  265. )
  266. ;;; 判断某个尺寸范围内是否有其它尺寸子函数
  267. (defun baohan (dim1 lst / chansu dim2 i name name01 pmax pmax01 pmin pmin01)
  268.   (setq name (car dim1)
  269. pmin (cadr dim1)
  270. pmax (caddr dim1)
  271. chansu "F"
  272. i 0
  273.   )
  274.   (while (and
  275.     (< i (length lst))
  276.     (/= chansu "Y")
  277.   )
  278.     (setq name01 (car (nth i lst))
  279.    pmin01 (cadr (nth i lst))
  280.    pmax01 (caddr (nth i lst))
  281.    dim2 (nth i lst)
  282.     )
  283.     (setq i (1+ i))
  284.     (if (or
  285.    (and
  286.      (<= (sswr pmin 1) (sswr pmin01 1))
  287.      (< (sswr pmax01 1) (sswr pmax 1))
  288.    )
  289.    (and
  290.      (< (sswr pmin 1) (sswr pmin01 1))
  291.      (<= (sswr pmax01 1) (sswr pmax 1))
  292.    )
  293. )
  294.       (setq chansu "T")
  295.     )
  296.     (if (or
  297.    (and
  298.      (< (sswr pmin 1) (sswr pmin01 1))
  299.      (< (sswr pmax 1) (sswr pmax01 1))
  300.      (< (sswr pmin01 1) (sswr pmax 1))
  301.    )
  302.    (and
  303.      (< (sswr pmin01 1) (sswr pmin 1))
  304.      (< (sswr pmax01 1) (sswr pmax 1))
  305.      (< (sswr pmin 1) (sswr pmax01 1))
  306.    )
  307. )
  308.       (setq chansu "Y")
  309.     )
  310.   )
  311.   chansu
  312. )
  313. ;;; 四舍五入函数,ent:实数,n:小数点保留位数
  314. (defun sswr (ent n / fh)
  315.   (if (>= ent 0.0)
  316.     (setq fh +)
  317.     (setq fh -)
  318.   )
  319.   (setq ent (/ (atof (itoa (fix (fh (* ent (expt 10 n)) 0.5)))) (expt 10 n)))
  320.   ent
  321. )
  322. ;;; 生成一个备份的列表
  323. (defun lstbak (lst / i lst02)
  324.   (setq lst02 '())
  325.   (repeat (setq i (length lst))
  326.     (setq lst02 (cons (nth (setq i (1- i))
  327.       lst
  328.         ) lst02
  329.   )
  330.     )
  331.   )
  332.   lst02
  333. )
  334. (defun Lguolv (ss / ent ent1 i ssguol) ; 下面程序设置过滤中心线虚线条件
  335.   (setq ssguol '("ACAD_ISO03W100" "ACAD_ISO02W100"
  336.   "DASHED" "DASHED2"
  337.   "DASHEDX2" "HIDDEN"
  338.   "HIDDEN2" "HIDDENX2"
  339.   "ACAD_ISO04W100" "ACAD_ISO08W100"
  340.   "CENTER" "CENTER2"
  341.   "CENTERX2" "DASHDOT"
  342.   "DASHDOT2" "DASHDOTX2"
  343. )
  344.   )           ; 下面程序将虚线中心线图层加入虚线过滤条件
  345.   (setq ssguol (append
  346.    SSguol
  347.    (guolv-01 "ACAD_ISO03W100")
  348.    (guolv-01 "ACAD_ISO02W100")
  349.    (guolv-01 "DASHED")
  350.    (guolv-01 "DASHED2")
  351.    (guolv-01 "DASHEDX2")
  352.    (guolv-01 "HIDDEN")
  353.    (guolv-01 "HIDDEN2")
  354.    (guolv-01 "HIDDENX2")
  355.    (guolv-01 "ACAD_ISO04W100")
  356.    (guolv-01 "ACAD_ISO08W100")
  357.    (guolv-01 "CENTER")
  358.    (guolv-01 "CENTER2")
  359.    (guolv-01 "CENTERX2")
  360.    (guolv-01 "DASHDOT")
  361.    (guolv-01 "DASHDOT2")
  362.    (guolv-01 "DASHDOTX2")
  363.         )
  364.   )           ; 下面程序将选择集中随层的过滤掉
  365.   (repeat (setq i (sslength ss))
  366.     (setq ent (ssname ss (setq i (1- i))))
  367.     (setq ent1 (entget ent))
  368.     (if (and
  369.    (member (cdr (assoc 8 ent1)) ssguol)
  370.    (/= (cdr (assoc 0 ent1)) "INSERT")
  371.    (= (assoc 6 ent1) nil)
  372. )
  373.       (setq ss (ssdel ent ss))
  374.     )
  375.   )           ; 下面程序将选择集中其他层的过滤掉
  376.   (repeat (setq i (sslength ss))
  377.     (setq ent (ssname ss (setq i (1- i))))
  378.     (setq ent1 (entget ent))
  379.     (if (member (cdr (assoc 6 ent1)) ssguol)
  380.       (setq ss (ssdel ent ss))
  381.     )
  382.   )
  383.   ss
  384. )
  385. (defun guolv-01 (xianxing / layers)
  386.   (setq layers '())
  387.   (setq layers (get_layer_linetype xianxing)) ; 获取包含指定线型的图层
  388.   layers
  389. )
  390. (defun get_layer_linetype (linetype / ly_info ly_infos tmplist) ; 提取包含指定线型的图层
  391.   (setq ly_Infos (get_layer))
  392.   (foreach ly_info ly_Infos
  393.     (if (= linetype (substr (cdr (assoc 6 ly_info)) 1 (strlen linetype)))
  394.       (setq tmplist (append
  395.         tmplist
  396.         (list (CDR (assoc 2 ly_info)))
  397.       )
  398.       )
  399.     )
  400.   )
  401.   tmplist
  402. )
  403. (defun get_layer (/ layer_info layers) ; 返回当前图纸中图层信息
  404.   (setq layer_info (tblnext "layer" t))
  405.   (while (/= layer_info nil)
  406.     (setq layers (append
  407.      layers
  408.      (list layer_info)
  409.    )
  410.     )
  411.     (setq layer_info (tblnext "layer"))
  412.   )
  413.   layers
  414. )




本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 12明经币 +14 金钱 +20 收起 理由
cwzxd + 1 + 20 很给力!
yoyoho + 1 很给力!
wsj249201 + 1
qjchen + 1 好程序
【KAIXIN】 + 1 赞一个!
自贡黄明儒 + 1 很给力!
linshiyin2 + 1 很给力!
zctao1966 + 1 很给力!
lohas1118 + 1 很给力!
gbhsu + 2

查看全部评分

"觉得好,就打赏"
还没有人打赏,支持一下

本帖被以下淘专辑推荐:

 楼主| 发表于 2012-1-15 19:57:36 | 显示全部楼层
本帖最后由 langjs 于 2012-1-15 19:58 编辑
fengsea 发表于 2012-1-15 12:53
一直寻找的lisp,太感谢LZ了!!!感觉V1版本貌似出错少些!还有要是能把输入值换成字高的倍数更方便些!


我编了一个根据字体高度的自动调整间距的,V1V2整合版,你看看是不是适合你:
;;;          《标注整理》v4.1
;;; ===================================================
;;; 功能:水平标注和垂直标注整理成等距离格式
;;; 使用:1单视图整理:命令bzzl,把一个视图连同标注选全,
;;;       2单方向整理:命令zl,选择同一个方向的标注整理,根据字体高度的自动调整间距
;;; 作者:langjs    qq:59509100     日期:2011年11月30日
;;; ===================================================
;;;
;;; 单方向标注整理主程序
(defun c:zl (/ bili ent hlst i lst name p0 p10 p10x p10y p13 p13x p13y p14 p14x p14y pan pany shezi ss uu vv zhigao)
  (setvar "CMDECHO" 0)
  (command ".UNDO" "BE")
  (vl-load-com)
  (setq bili (getvar "DIMSCALE"))
  (setq ss (ssget '((0 . "DIMENSION"))))
  (setq ss (ssgengxin ss))
  (setq zhigao (biaozzg ss))
  (setq pany (* zhigao bili 1.6))
  (setq shezi "R")
  (while (/= (type shezi) 'list)
    (initget "S ")
    (princ (strcat "\n指定尺寸偏移起点,或<不改变>:[默认尺寸间距<" (rtos pany 2 1) ">重新设置(S)]"))
    (setq shezi (getpoint ""))
    (if (= shezi "S")
      (setq pany (getreal (strcat "\n设置尺寸间距:<" (rtos pany 2 1) ">")))
      (setq p0 shezi)
    )
  )
  (if (/= p0 nil)
    (fenxiangxianbiaozhu ss p0 pany)
  )
  (setq p00 (getpoint "\n指定引出线位置,或<不改变>:"))
  (if p00
    (repeat (setq i (sslength ss))
      (setq ent (ssname ss (setq i (1- i))))
      (setq ent (entget ent))
      (jisuanshuju01 ent p00)
      (gengxinchichunjiexian01 ent np13 np14)
    )
    (princ)
  )
  (command ".UNDO" "E")
  (princ)
)
;;; 单视图标注整理主程序
(defun c:bzzl (/ bili end end_data ent i maxp maxx maxx0 maxy maxy0 minp minx minx0 miny miny0 name p10 p10x p10y p13 p13x p13y p14
                 p14x p14y pan pany pmax pmin ss ss00 ss01 ss02 ss03 ss04 zhigao
              )
  (vl-load-com)
  (setvar "CMDECHO" 0)
  (command ".UNDO" "BE")
  (setq bili (getvar "DIMSCALE"))
  (setq ss00 (ssget '((0 . "DIMENSION,LINE,LWPOLYLINE,INSERT"))))
  (setq zhigao (biaozzg ss00))
  (setq pany (* zhigao bili 1.6))      ; 此处设置“默认尺寸间距”为字高的1.6倍
  (setq ss (ssadd)
        ss01 (ssadd)
        ss02 (ssadd)
        ss03 (ssadd)
        ss04 (ssadd)
  )
  (repeat (setq i (sslength ss00))
    (setq name (ssname ss00 (setq i (1- i))))
    (if (= (cdr (assoc 0 (entget name))) "DIMENSION")
      (progn
        (setq ent (entget name))
        (setq p10 (cdr (assoc 10 ent))
              p13 (cdr (assoc 13 ent))
              p14 (cdr (assoc 14 ent))
              p10x (car p10)
              p10y (cadr p10)
              p13x (car p13)
              p13y (cadr p13)
              p14x (car p14)
              p14y (cadr p14)
        )
        (if (> (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
          (setq ss01 (ssadd name ss01))
        )
        (if (> (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
          (setq ss02 (ssadd name ss02))
        )
        (if (< (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
          (setq ss03 (ssadd name ss03))
        )
        (if (< (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
          (setq ss04 (ssadd name ss04))
        )
      )
      (setq ss (ssadd name ss))
    )
  )
  (setq ss (lguolv ss))
  (if (>= (sslength ss) 1)
    (progn
      (setq minx0 1e6
            miny0 1e6
            maxx0 -1e6
            maxy0 -1e6
      )
      (repeat (setq i (sslength ss))
        (setq end (ssname ss (setq i (1- i))))
        (setq end_data (entget end))
        (vla-getboundingbox (vlax-ename->vla-object end) 'minp 'maxp)
        (setq minp (vlax-safearray->list minp)
              maxp (vlax-safearray->list maxp)
              minx (car minp)
              maxx (car maxp)
              miny (cadr minp)
              maxy (cadr maxp)
        )
        (if (> minx0 minx)
          (setq minx0 minx)
        )
        (if (> miny0 miny)
          (setq miny0 miny)
        )
        (if (< maxx0 maxx)
          (setq maxx0 maxx)
        )
        (if (< maxy0 maxy)
          (setq maxy0 maxy)
        )
      )
      (setq pmin (list minx0 miny0)
            pmax (list maxx0 maxy0)
      )
      (fenxiangxianbiaozhu ss01 pmax pany)
      (fenxiangxianbiaozhu ss02 pmax pany)
      (fenxiangxianbiaozhu ss03 pmin pany)
      (fenxiangxianbiaozhu ss04 pmin pany)
    )
  )
  (command ".UNDO" "E")
  (princ)
)
;;; 分方向标注子函数
(defun fenxiangxianbiaozhu (ss p0 pany / ent hlst i lst name p10 p10x p10y p13 p13x p13y p14 p14x p14y uu vv)
  (setq lst '()
        hlst '()
  )
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i))))
    (setq ent (entget name))
    (setq p10 (cdr (assoc 10 ent))
          p13 (cdr (assoc 13 ent))
          p14 (cdr (assoc 14 ent))
          p10x (car p10)
          p10y (cadr p10)
          p13x (car p13)
          p13y (cadr p13)
          p14x (car p14)
          p14y (cadr p14)
    )
    (cond
      ((= (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
        (if (< p13x p14x)
          (setq lst (cons (list name p13x p14x) lst))
          (setq lst (cons (list name p14x p13x) lst))
        )
      )
      ((= (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
        (if (< p13y p14y)
          (setq hlst (cons (list name p13y p14y) hlst))
          (setq hlst (cons (list name p14y p13y) hlst))
        )
      )
      (t
        (princ)
      )
    )
  )
  (setq uu 0
        vv 1
  )
  (biaozhu lst p0 uu vv pany)               ; 处理水平标注
  (setq uu 1
        vv 0
  )
  (biaozhu hlst p0 uu vv pany)               ; 处理垂直标注
  (princ)
)
;;; 计算坐标点,尺寸更新到合适位置子函数
(defun biaozhu (lst p0 uu vv pany / bili chansu dim1 ent fuh fuh1 i lst_p1314x lst_p1314y lst02 lst04 n name p0x p0y p10 p10x p10y
                    p11 p11x p11y p13 p13x p13y p14 p14x p14y pl pmax pmin
               )
  (setq bili (getvar "DIMSCALE")
        pl (getvar "DIMEXE")
        n 1
  )
  (while (> (length lst) 0)               ; 如果标注还有标注列表着循环
    (setq p0x (car p0)
          p0y (cadr p0)
          lst02 (lstbak lst)               ; 将列表备份一个
          lst04 '()
          lst_p1314x '()
          lst_p1314y '()
    )                                       ; 对列表的标注循环
    (repeat (setq i (length lst))
      (setq dim1 (nth (setq i (1- i))
                      lst
                 )
      )
      (setq name (car dim1)
            pmin (cadr dim1)
            pmax (caddr dim1)
      )
      (setq chansu (baohan dim1 lst))  ; 判断这个元素是否包含其它尺寸如无则更新。
      (if (= chansu "F")
        (progn
          (setq ent (entget name))
          (setq p10 (cdr (assoc 10 ent))
                p11 (cdr (assoc 11 ent))
                p13 (cdr (assoc 13 ent))
                p14 (cdr (assoc 14 ent))
                p10x (car p10)
                p10y (cadr p10)
                p11x (car p11)
                p11y (cadr p11)
                p13x (car p13)
                p13y (cadr p13)
                p14x (car p14)
                p14y (cadr p14)
          )
          (if (> p10y p13y)
            (setq fuh 1)
            (setq fuh -1)
          )
          (if (> p10x p13x)
            (setq fuh1 1)
            (setq fuh1 -1)
          )
          (setq p10 (list (+ (* vv p10x) (* uu p0x) (* uu fuh1 n pany)) (+ (* uu p10y) (* vv p0y) (* vv fuh n pany))))
          (setq p11 (list (+ (* vv p11x) (* uu p0x) (* uu fuh1 n pany)) (+ (* uu p11y) (* vv p0y) (* vv fuh n pany))))
          (setq lst02 (vl-remove dim1 lst02))
          (setq ent (subst
                      (cons 10 p10)
                      (assoc 10 ent)
                      ent
                    )
          )
          (setq ent (subst
                      (cons 11 p11)
                      (assoc 11 ent)
                      ent
                    )
          )
          (entmod ent)
        )
      )
    )
    (setq n (1+ n))
    (setq lst lst02)
  )
  (princ)
)
;;; 判断某个尺寸范围内是否有其它尺寸子函数
(defun baohan (dim1 lst / chansu dim2 e1 e2 i jili jili01 lst03 name name01 pmax pmax01 pmin pmin01)
  (setq name (car dim1)
        pmin (cadr dim1)
        pmax (caddr dim1)
        jili (sswr (- pmax pmin) 1)
        chansu "F"
        lst03 '()
  )
  (repeat (setq i (length lst))
    (setq name01 (car (nth (setq i (1- i))
                           lst
                      )
                 )
          pmin01 (cadr (nth i lst))
          pmax01 (caddr (nth i lst))
          jili01 (- pmax01 pmin01)
          dim2 (nth i lst)
    )
    (if (or
          (and
            (<= (sswr pmin 1) (sswr pmin01 1))
            (< (sswr pmax01 1) (sswr pmax 1))
          )
          (and
            (< (sswr pmin 1) (sswr pmin01 1))
            (<= (sswr pmax01 1) (sswr pmax 1))
          )
        )
      (setq chansu "T")
    )
    (if (or
          (and
            (< (sswr pmin 1) (sswr pmin01 1))
            (< (sswr pmax 1) (sswr pmax01 1))
            (< (sswr pmin01 1) (sswr pmax 1))
          )
          (and
            (< (sswr pmin01 1) (sswr pmin 1))
            (< (sswr pmax01 1) (sswr pmax 1))
            (< (sswr pmin 1) (sswr pmax01 1))
          )
        )
      (setq lst03 (cons (list name01 (sswr jili01 1)) lst03))
    )
  )
  (setq lst03 (vl-sort lst03 (function (lambda (e1 e2)
                                         (< (cadr e1) (cadr e2))
                                       )
                             )
              )
  )
  (if (>= (length lst03) 1)
    (progn
      (if (> jili (cadr (car lst03)))
        (setq chansu "T")
      )
      (repeat (setq i (length lst03))
        (if (= jili (cadr (nth (setq i (1- i))
                               lst03
                          )
                    )
            )
          (setq lst04 (cons (nth i lst03) lst04))
        )
      )
    )
  )
  (if (member (list name jili) lst04)
    (setq chansu "T")
  )
  (princ "\n程序正在计算,请稍后......")
  chansu
)
;;; 将误选的横纵标注(少数量)从选择集中删除子函数
(defun ssgengxin (ss / ent i name p10 p10x p10y p14 p14x p14y ss1 ss2)
  (setq ss1 (ssadd)
        ss2 (ssadd)
  )
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i))))
    (setq ent (entget name))
    (setq p10 (cdr (assoc 10 ent))
          p14 (cdr (assoc 14 ent))
          p10x (car p10)
          p10y (cadr p10)
          p14x (car p14)
          p14y (cadr p14)
    )
    (cond
      ((= (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
        (setq ss1 (ssadd name ss1))
      )
      ((= (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
        (setq ss2 (ssadd name ss2))
      )
      (t
        (princ)
      )
    )
  )
  (if (>= (sslength ss1) (sslength ss2))
    (setq ss ss1)
    (setq ss ss2)
  )
  ss
)
;;; 四舍五入函数,ent:实数,n:小数点保留位数
(defun sswr (ent n / fh)
  (if (>= ent 0.0)
    (setq fh +)
    (setq fh -)
  )
  (setq ent (/ (atof (itoa (fix (fh (* ent (expt 10 n)) 0.5)))) (expt 10 n)))
  ent
)
;;; 生成一个备份的列表
(defun lstbak (lst / i lst02)
  (setq lst02 '())
  (repeat (setq i (length lst))
    (setq lst02 (cons (nth (setq i (1- i))
                           lst
                      ) lst02
                )
    )
  )
  lst02
)
(defun lguolv (ss / ent ent1 i ssguol) ; 下面程序设置过滤中心线虚线条件
  (setq ssguol '("ACAD_ISO03W100" "ACAD_ISO02W100"
         "DASHED" "DASHED2"
         "DASHEDX2" "HIDDEN"
         "HIDDEN2" "HIDDENX2"
         "ACAD_ISO04W100" "ACAD_ISO08W100"
         "CENTER" "CENTER2"
         "CENTERX2" "DASHDOT"
         "DASHDOT2" "DASHDOTX2"
        )
  )                                       ; 下面程序将虚线中心线图层加入虚线过滤条件
  (setq ssguol (append
                 ssguol
                 (guolv-01 "ACAD_ISO03W100")
                 (guolv-01 "ACAD_ISO02W100")
                 (guolv-01 "DASHED")
                 (guolv-01 "DASHED2")
                 (guolv-01 "DASHEDX2")
                 (guolv-01 "HIDDEN")
                 (guolv-01 "HIDDEN2")
                 (guolv-01 "HIDDENX2")
                 (guolv-01 "ACAD_ISO04W100")
                 (guolv-01 "ACAD_ISO08W100")
                 (guolv-01 "CENTER")
                 (guolv-01 "CENTER2")
                 (guolv-01 "CENTERX2")
                 (guolv-01 "DASHDOT")
                 (guolv-01 "DASHDOT2")
                 (guolv-01 "DASHDOTX2")
               )
  )                                       ; 下面程序将选择集中随层的过滤掉
  (repeat (setq i (sslength ss))
    (setq ent (ssname ss (setq i (1- i))))
    (setq ent1 (entget ent))
    (if (and
          (member (cdr (assoc 8 ent1)) ssguol)
          (/= (cdr (assoc 0 ent1)) "INSERT")
          (= (assoc 6 ent1) nil)
        )
      (setq ss (ssdel ent ss))
    )
  )                                       ; 下面程序将选择集中其他层的过滤掉
  (repeat (setq i (sslength ss))
    (setq ent (ssname ss (setq i (1- i))))
    (setq ent1 (entget ent))
    (if (member (cdr (assoc 6 ent1)) ssguol)
      (setq ss (ssdel ent ss))
    )
  )
  ss
)
(defun guolv-01 (xianxing / layers)
  (setq layers '())
  (setq layers (get_layer_linetype xianxing)) ; 获取包含指定线型的图层
  layers
)
(defun get_layer_linetype (linetype / ly_info ly_infos tmplist)        ; 提取包含指定线型的图层
  (setq ly_infos (get_layer))
  (foreach ly_info ly_infos
    (if (= linetype (substr (cdr (assoc 6 ly_info)) 1 (strlen linetype)))
      (setq tmplist (append
                      tmplist
                      (list (cdr (assoc 2 ly_info)))
                    )
      )
    )
  )
  tmplist
)
(defun get_layer (/ layer_info layers) ; 返回当前图纸中图层信息
  (setq layer_info (tblnext "LAYER" t))
  (while (/= layer_info nil)
    (setq layers (append
                   layers
                   (list layer_info)
                 )
    )
    (setq layer_info (tblnext "LAYER"))
  )
  layers
)
;;; 计算坐标点子程序
(defun jisuanshuju01 (ent p00 / p00x p00y p0x p0y p10 p10x p10y p11 p11x p11y p13 p13x p13y p14 p14x p14y)
  (setq p00x (car p00)
        p00y (cadr p00)
  )                                       ; 取得标注各关键坐标点值
  (setq p10 (cdr (assoc 10 ent))
        p14 (cdr (assoc 14 ent))
        p11 (cdr (assoc 11 ent))
        p13 (cdr (assoc 13 ent))
        p10x (car p10)
        p10y (cadr p10)
        p14x (car p14)
        p14y (cadr p14)
        p11x (car p11)
        p11y (cadr p11)
        p13x (car p13)
        p13y (cadr p13)
  )                                       ; 判断横、纵坐标并计算对齐后的关键标注坐标点值
  (cond
    ((= (fix (+ 0.5 p10x)) (fix (+ 0.5 p14x)))
      (setq np13 (list p13x p00y 0.0)
            np14 (list p14x p00y 0.0)
      )
    )
    ((= (fix (+ 0.5 p10y)) (fix (+ 0.5 p14y)))
      (setq np13 (list p00x p13y 0.0)
            np14 (list p00x p14y 0.0)
      )
    )
    (t
      (exit)
    )
  )
  (princ)
)
(defun gengxinchichunjiexian01 (ent np13 np14) ; 对齐引出线子程序
  (setq ent (subst
              (cons 13 np13)
              (assoc 13 ent)
              ent
            )
  )
  (setq ent (subst
              (cons 14 np14)
              (assoc 14 ent)
              ent
            )
  )
  (entmod ent)
  (princ)
)
(defun biaozzg (ss / bl dim i lst name wzgd wzh)
  (setq lst '())
  (repeat (setq i (sslength ss))
    (setq name (ssname ss (setq i (1- i))))
    (if (= (cdr (assoc 0 (entget name))) "DIMENSION")
      (progn
        (setq dim (vlax-ename->vla-object name))
        (setq wzgd (vla-get-textheight dim)) ; 得到标注样式的文字高度
        (setq bl (vla-get-scalefactor dim)) ; 得到标注的调整比例
        (setq wzh (* wzgd bl))               ; 得到真正的文字高度
        (setq lst (cons wzh lst))
      )
    )
  )
  (setq lst (vl-sort lst '>))
  (car lst)
)

评分

参与人数 1金钱 +10 收起 理由
fengsea + 10 很给力!

查看全部评分

回复 支持 1 反对 1

使用道具 举报

发表于 2022-10-29 11:28:06 | 显示全部楼层
langjs 发表于 2012-1-15 19:57
我编了一个根据字体高度的自动调整间距的,V1V2整合版,你看看是不是适合你:
;;;          《标注 ...

加载程序后显示“输入中的点位置不正确”是怎么原因啊?求指点

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
回复 支持 1 反对 0

使用道具 举报

发表于 2011-11-26 12:16:22 来自手机 | 显示全部楼层
非常不错,难得一见的好铁!
回复 支持 1 反对 0

使用道具 举报

发表于 2011-11-25 23:37:47 | 显示全部楼层
很好。一直想编这样的,就是没时间。
发表于 2011-11-26 07:38:25 | 显示全部楼层
2.0版和1.0版相比有什么区别》
发表于 2011-11-26 08:02:28 | 显示全部楼层
顶一个,,,我正想发贴找这样的呢,,,,
发表于 2011-11-26 08:17:58 | 显示全部楼层
子程序
GET_LAYER_LINETYPE
呢?

点评

不好意思漏发了几个函数,已经更新了  发表于 2011-11-26 14:13
发表于 2011-11-26 09:37:02 | 显示全部楼层
就是啊,子程序没提供啊?

点评

不好意思漏发了几个函数,已经更新了  发表于 2011-11-26 14:14
发表于 2011-11-26 10:36:02 | 显示全部楼层
错误: no function definition: GET_LAYER_LINETYPE
发表于 2011-11-26 10:43:24 | 显示全部楼层
好东西
发表于 2011-11-26 13:51:38 | 显示全部楼层
很不错的程序,支持楼主、
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-22 10:32 , Processed in 0.273251 second(s), 39 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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