日志

标注对齐命令

热度 1已有 573 次阅读2014-12-6 23:17 |系统分类:应用

;http://bbs.mjtd.com/forum.php?mod=viewthread&tid=108799
;标注对齐命令 tdx

;2013-12-23~24 by edata
;cad 2006 wcs/ucs 没问题
;只支持转角标注和对齐标注
;引线只修改第一点
(defun c:tdx(/ ANG E EN N10 N13 N14 O10 O13 O14 O42 P1 P2 SS K13 LE10 LE11 NLE10)
  (defun *error*_New (msg)
  (vl-load-com)
  (if *error*_Old(setq *error* *error*_Old))
  (if (wcmatch (strcase msg t) "*break,*cancel*,*exit*,*取消*")
(princ)
  )
  (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
  (princ)
)
  (setq *error*_Old *error*)
(setq *error* *error*_New)
  ;;;计算cp到p1 p2的垂足点 gu_xl
(defun PerToLine  (cp p1 p2 / norm)
  (setq       norm (mapcar '- p2 p1)
      p1 (trans p1 0 norm)
      cp (trans cp 0 norm)
      )
  (trans (list (car p1) (cadr p1) (caddr cp)) norm 0)
  )
  ;;;判断三点共线 highflybird
(defun LINE:Colinearity (p1 p2 p3 / a b c eps)
  (setq eps 1e-8)
  (setq a (distance p2 p3))
  (setq b (distance p3 p1))
  (setq c (distance p1 p2))
  (or (equal (+ a b) c eps)
   (equal (+ b c) a eps)
   (equal (+ c a) b eps)
   )
  )
  ;;;已知斜边两点和另一边,求直角三角形直角点坐标
  (defun sk_djp3(p1 p2 ds / A ANG B C D H PT1 QQ S XD)
  (if (and p1 p2 ds)
(progn
   (setq c(distance p1 p2)
      a ds
      b (sqrt (abs(- (* c c) (* a a))))
      ang(angle p1 p2)
      pt1 p1)
   (setq qq (/ (+ a b c) 2.0))
   (setq s (sqrt (abs(* qq (- qq a) (- qq b) (- qq c)))))
   (setq h (/ (* s 2.0) c))
   (setq d (sqrt (abs(- (* a a) (* h h)))))
   (setq xd(polar pt1 ang d))
   (polar xd (+ ang (* pi 0.5)) h)
   )
)
  )
;;;取得图元名的组码值
  (defun sK_dxf(en code / e)
  (setq e(entget en))
  (cdr (assoc code e)))
  ;;;主程序
  (if(setq ss(ssget '((-4 . "<or")
      (-4 . "<and")
      (0 . "DIMENSION")
      (-4 . "<or")
      (70 . 33)
      (70 . 32)
      (-4 . "or>")
      (-4 . "and>")
      (0 . "LEADER")
      (-4 . "or>")
      )
      )
   )
  (if (setq p1(getpoint "\n指定新的尺寸界线原点<不改动>:"))
(setq p2(getpoint p1 "\n指定新的尺寸线位置<不改动>:"))
(setq p2(getpoint "\n指定新的尺寸线位置<不改动>:"))))
  (if (and ss (or p1 p2))
(progn
   (and p1(setq p1(trans p1 1 0)))
   (and p2(setq p2(trans p2 1 0)))
   (vla-StartUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
   (while (setq en (ssname ss 0))
(setq e(entget en))
(cond
   ((and (= (sK_dxf en 0) "DIMENSION")(member (sK_dxf en 70) (list 32 33)))
   (setq o13(sK_dxf en 13)
   o14(sK_dxf en 14)
   o10(sK_dxf en 10)
   o42(sK_dxf en 42))
   (setq k13 (sk_djp3 o10 o13 o42))
   (cond
      ((and (equal o14 o10 1e-8)(not (equal o13 k13 1e-8))) ;(princ"\n两点共线")
      (setq o14 (sk_djp3 o13 o10 o42))
      )
      ((and (LINE:Colinearity o10 o13 o14) ) ;(princ"\n三点共线")
   (setq o14 (polar o14 (+ (angle o13 o14) (* pi 0.5)) 10))
   (setq o13 (polar o13 (+ (angle o13 o14) (* pi 0.5)) 10))
   )
   )
   (and p1  (setq n14(PerToLine p1 o14 o10)
   ang(angle (PerToLine o13  o14 o10)  o13)
   n13(polar n14 ang o42)
   ))
   (and p2 (setq n10(PerToLine p2 o14 o10)))
   (and n13(setq e(subst (cons 13 n13)(assoc 13 e) e)))
   (and n14(setq e(subst (cons 14 n14)(assoc 14 e) e)))
   (and n10(setq e(subst (cons 10 n10)(assoc 10 e) e)))
   (and e(entmod e))
   )
   ((and (= (sK_dxf en 0) "LEADER") p1)
   (setq le10 (vlax-curve-getPointAtParam en 0))
   (setq le11 (vlax-curve-getPointAtParam en 1))
   (setq nle10 (PerToLine p1 le11 le10))
   (entmod (subst (cons 10 nle10)(assoc 10 e) e))
   ;(vlax-curve-getPointAtParam en 2)
   )
   );cond
(setq ss(ssdel en ss))
)
   (vla-EndUndoMark (vla-get-ActiveDocument (vlax-get-acad-object)))
   )
)
  (princ)
  )
(vl-load-com)
(prompt"\n标注对齐命令 tdx")
(princ)