CAD标注对齐源程序分享

根据网友建议修改更新于2010年12月31日。（网上有个某老大做的尺寸标注对齐的源程序，但是在对齐尺寸时，尺寸界线也发生移动。本人编写了一个尺寸标注对齐的程序，在对齐时候尺寸界线不移动，可能效果好一些，请大家试用。在明经里边学到很多东西，自己也献献丑，做的东西分享给大家。）

_______________________________________________________;;; 标注对齐     langjs 2011.11.26
;;; (本程序仅适用于多个水平或垂直标注对齐)
;;; _______________________________________________________
(defun c:qq (/ ent i name np10 np11 np13 np14 p0 p00 p10 p11 p13 p14 ss ss1 ss2 u v)
  (defun ssgengxin (ss / ent i name p10 p14 ss1 ss2) ; 将误选的横纵标注（少数量）从选择集中删除?
    (setq ss1 (ssadd)  ss2 (ssadd))
    (repeat (setq i (sslength ss))
      (setq ent (entget (setq name (ssname ss (setq i (1- i)))))
            p10 (cdr (assoc 10 ent))  p14 (cdr (assoc 14 ent))
      )
      (cond
        ((= (fix (+ 0.5 (car p10))) (fix (+ 0.5 (car p14))))
          (setq ss1 (ssadd name ss1))
        )
        ((= (fix (+ 0.5 (cadr p10))) (fix (+ 0.5 (cadr p14))))
          (setq ss2 (ssadd name ss2))
        )
        (t )
      )
    )
    (if (>= (sslength ss1) (sslength ss2))  ss1  ss2 )
  )
  (defun jisuan (ent / p10 p11 p13 p14)        ; 计算坐标点子程序
    (setq p10 (cdr (assoc 10 ent))  p14 (cdr (assoc 14 ent))
          p11 (cdr (assoc 11 ent))  p13 (cdr (assoc 13 ent))
    )
    (cond
      ((= (fix (+ 0.5 (car p10))) (fix (+ 0.5 (car p14))))
        (setq np10 (list (car p10) (cadr p0))
              np11 (list (car p11) (+ (- (cadr p11) (cadr p10)) (cadr p0)))
              np13 (list (car p13) (cadr p00))
              np14 (list (car p14) (cadr p00))
        )
      )
      ((= (fix (+ 0.5 (cadr p10))) (fix (+ 0.5 (cadr p14))))
        (setq np10 (list (car p0) (cadr p10))
              np11 (list (+ (- (car p11) (car p10)) (car p0)) (cadr p11))
              np13 (list (car p00) (cadr p13))
              np14 (list (car p00) (cadr p14))
        )
      )
    )
   )
  (defun gengxin (ent u np10 v np11)
    (setq ent (subst(cons u np10)(assoc u ent) ent ))
    (entmod (subst  (cons v np11)(assoc v ent) ent ))
  )
  (setvar "cmdecho" 0)                       ; 关闭命令响应
  (if (setq ss (ssget '((0 . "DIMENSION"))))
    (progn
      (setq ss (ssgengxin ss))
      (if (setq p0 (getpoint "\n指定标注线位置,或<不改变>:"))
        (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i)))))
          (jisuan ent)
          (gengxin ent 10 np10 11 np11)
        )
        (setq p0 '(0.0 0.0))
      )
      (if (setq p00 (getpoint "\n指定引出线位置,或<不改变>:"))
        (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i)))))
          (jisuan ent)
          (gengxin ent 13 np13 14 np14)
        )
      )
    )
  )
  (princ)
)