标注整理v1.0源程序

langjs

编写了一个标注尺寸整理程序，水平标注和垂直标注整理成等距离格式.请各位大虾指点





应网友要求做了个带引出线基点找齐的程序，在20楼。

;;; 　　　      《标注整理》v1.0
;;; ============================================
;;; 功能：水平标注和垂直标注整理成等距离格式
;;;       命令：BZZL
;;; 作者：langjs qq:59509100 日期:2011年11月21日
;;; ============================================
(defun C:BZZL (/ 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")
  (setq ss (ssget '((0 . "DIMENSION"))))
  (setq ss (ssgengxin ss))
  (setq zhigao (getvar "DIMTXT")
pan (getvar "DIMGAP")
bili (getvar "DIMSCALE")
  )
  (setq pany (* (+ zhigao pan) bili 1.5)) ; 此处设置“默认尺寸间距”为字高加偏移的1.5倍
  (while (not p0)
    (if xuanzeWS01bak
      (setq pany xuanzeWS01bak)
      (setq xuanzeWS01bak pany)
    )
    (initget "S ")
    (princ (strcat "\n指定尺寸偏移起点，或[当前尺寸间距<" (rtos pany 2 1) ">，重新设置(S)]:"))
    (setq shezi (getpoint ""))
    (if (= shezi "S")
      (progn
(setq pany (getreal (strcat "\n设置尺寸间距:<" (rtos pany 2 1) ">")))
(setq xuanzeWS01bak pany)
      )
      (setq p0 shezi)
    )
  )
  (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))
    )
    (setq 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)        ; 处理垂直标注
  (command ".UNDO" "E")
  (princ)
)
;;; 计算坐标点，尺寸更新到合适位置子函数
(defun biaozhu (lst p0 uu vv pany / chansu dim1 ent fuh fuh1 i j lst02 n name p0x p0y p10 p10x p10y p11 p11x p11y p13 p13x p13y p14
      p14x p14y pmax pmin
        )
  (setq n 1)
  (while (> (length lst) 0)
    (setq i 0
   p0x (car p0)
   p0y (cadr p0)
    )
    (setq j 0
   lst02 '()
    )
    (while (< j (length lst))
      (setq lst02 (cons (nth j lst) lst02))
      (setq j (1+ j))
    )
    (setq lst02 (reverse lst02))
    (while (< i (length lst))
      (setq dim1 (nth i lst))
      (setq i (1+ i))
      (setq name (car dim1)
     pmin (cadr dim1)
     pmax (caddr dim1)
      )
      (setq chansu (baohan dim1 lst))
      (if (or
     (= chansu "F")
     (= chansu "Y")
   )
(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))
   )
   (setq 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 p1 (list (+ p0x (* uu (* fuh1 (* n pany)))) (+ p0y (* vv (* fuh (* n pany))))
   (setq lst02 (vl-remove dim1 lst02))
   (if (= chansu "Y")
     (setq n (1+ n))
   )
   (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 i name name01 pmax pmax01 pmin pmin01)
  (setq name (car dim1)
pmin (cadr dim1)
pmax (caddr dim1)
chansu "F"
i 0
  )
  (while (and
    (< i (length lst))
    (/= chansu "Y")
  )
    (setq name01 (car (nth i lst))
   pmin01 (cadr (nth i lst))
   pmax01 (caddr (nth i lst))
   dim2 (nth i lst)
    )
    (setq i (1+ i))
    (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 chansu "Y")
    )
  )
  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))
    )
    (setq 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
)

zhangcn

再加个文字避让就完美了！

zhangrunze

感谢分享~
小工具大作用~

lee50310

多謝很實用很好支持

cnks

有这个比较方便，顶了

lrd1861

支持一下加个币

MaKaiJin

强，支持，学习改进

laoqian123

期待这个功能很久了，楼主太给力了！

daidong013

先顶一下！~楼主如果可以加上排齐脚点就更好了！~呵呵！~~

flytoday

太强大了

flytoday

请大侠修改下啊。。用于天正标注调整不行哦

langjs

flytoday 发表于 2011-11-24 11:24
请大侠修改下啊。。用于天正标注调整不行哦

我没安装天正，你把一张天正标注的图纸发到我信箱：59509100@qq.com，我看看能不能改程序

flytoday