自动坐标标注源码

525532251

[sell=1](defun C:zd (/ dimt dimTad err txtSize s)
  (command "UNDO" "BE")
  (setq        dimt (getvar "DIMTMOVE")
        dimTad (getvar "DIMTAD")
        txtSize (getvar "TEXTSIZE")
        s (getvar "DIMSCALE")
  )
  (if (= s 0.0)
    (setq s 1.0)
  )
  (setvar "DIMTMOVE" 0)
  (setvar "DIMTAD" 0)
  (setvar "TEXTSIZE" (* s (getvar "DIMTXT")))
  (setq        err (vl-catch-all-apply 'ac-autoDim nil))
  (if (vl-catch-all-error-p err)
    (progn
      ;; add some error handles here
    )
  )
  (setvar "DIMTMOVE" dimt)
  (setvar "DIMTAD" dimTad)
  (setvar "TEXTSIZE" txtSize)
  (command "UNDO" "E")
)

;;;
;;; global variables: dd, posRec, stPos
;;; main function
(defun ac-autoDim(/ ss ent i inf pt-pairs xs ys x1 x2 y1 y2 xinfs yinfs sub-xinfs sub-yinfs xinf2 yinf2 cpt gap
                  dd posRec sEnt sEnts cirPak arcPak cirPaks arcPaks newCirPaks newArcPaks)
(PRINC "\n--自动坐标标注 ")(PRINC)
(setq ss (ssget)
        pt (getpoint "\n请指定坐标原点: ")
        ent (ssname ss 0)
        i 0
        dd (* (getvar "DIMSCALE") (+ (getvar "DIMTXT") (* 2.0 (getvar "DIMGAP"))))
        posRec (list nil nil nil nil nil nil nil nil)
  )
  (command "UCS" "O" pt)
  (while ent
    (setq inf (ac-dimInf ent))
    (if        inf
      (progn
        (setq sub-xinfs        (nth 0 inf)
              sub-yinfs        (nth 1 inf)
              xs        (append (nth 2 inf) xs)
              ys        (append (nth 3 inf) ys)
              sEnt (nth 4 inf)
              cirPak (nth 5 inf)
              arcPak (nth 6 inf)
        )
        (foreach xinf1 sub-xinfs
          (setq xinf2 (assoc (car xinf1) xinfs))
          (if xinf2
            (setq xinfs (subst (list (car xinf2) (cadr xinf2) (append (nth 2 xinf2) (nth 2 xinf1))) xinf2 xinfs))
            (setq xinfs (cons xinf1 xinfs))
          )
        )
        (foreach yinf1 sub-yinfs
          (setq yinf2 (assoc (car yinf1) yinfs))
          (if yinf2
            (setq yinfs (subst (list (car yinf2) (cadr yinf2) (append (nth 2 yinf2) (nth 2 yinf1))) yinf2 yinfs))
            (setq yinfs (cons yinf1 yinfs))
          )
        )
        (if sEnt
          ;; un-orthogonal line
          (setq sEnts (cons sEnt sEnts))
        )
        (if cirPak
          (setq cirPaks (cons cirPak cirPaks))
        )
        (if arcPak
          (setq arcPaks (cons arcPak arcPaks))
        )
      )
    )
    (setq i (1+ i)
          ent (ssname ss i)
    )
  )
  ;; find the center of objects
  (setq x1 (apply 'min xs)
        x2 (apply 'max xs)
        y1 (apply 'min ys)
        y2 (apply 'max ys)
        cpt (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0) 0.0)
        gap (* 2.0 dd)
        stPos (list (- x1 gap) (+ x2 gap) (- y1 gap) (+ y2 gap))
  )
  ;; dimension position
  (setq xinfs (vl-sort xinfs '(lambda(a b) (< (abs (- (cadr a) (car cpt))) (abs (- (cadr b) (car cpt))))))
        yinfs (vl-sort yinfs '(lambda(a b) (< (abs (- (cadr a) (cadr cpt))) (abs (- (cadr b) (cadr cpt))))))
  )
  (ac-dimInfs xinfs cpt "x")
  (ac-dimInfs yinfs cpt "y")
  ;; dimension angle
  (foreach sEnt sEnts
    (ac-dimAngle sEnt)
  )
  ;; dimension diameter & radius
  (setq newCirPaks (ac-reducePaks cirPaks))
  (setq newArcPaks (ac-reducePaks arcPaks))
  (ac-dimCirArc newCirPaks "cir")
  (ac-dimCirArc newArcPaks "arc")
  (command "UCS" "P")
)

;;;
(defun ac-dimInf(ent / dat typ p1 p2 x1 y1 x2 y2 ang ang2 xs ys xinfs yinfs inf rad sEnt cirPak arcPak)
  (setq dat (entget ent)
        typ (cdr (assoc 0 dat))
  )
  (cond        ((= typ "LINE")
         (setq p1      (trans (cdr (assoc 10 dat)) 0 1)
               p2      (trans (cdr (assoc 11 dat)) 0 1)
               x1 (car p1)
               y1 (cadr p1)
               x2 (car p2)
               y2 (cadr p2)
               ang     (angle p1 p2)
               ang2 (rem ang pi)
               xs      (list x1 x2)
               ys      (list y1 y2)
               sEnt nil
         )
         (cond ((or (equal ang2 0.0 0.01) (equal ang2 pi 0.01) (equal ang2 (* 2.0 pi) 0.01))
                ;; horizontal
                (setq yinfs (list (list (rtos y1 2 4) y1 (list x1 x2)))
                      xinfs nil
                )
               )
               ((or (equal ang2 (* 0.5 pi) 0.01) (equal ang2 (* 1.5 pi) 0.01))
                ;; vertical
                (setq xinfs (list (list (rtos x1 2 4) x1 (list y1 y2)))
                      yinfs nil
                )
               )
               (T
                ;; un-orthogonal
                (setq yinfs (list (list (rtos y1 2 4) y1 (list x1)) (list (rtos y2 2 4) y2 (list x2)))
                      xinfs (list (list (rtos x1 2 4) x1 (list y1)) (list (rtos x2 2 4) x2 (list y2)))
                      sEnt ent
                )
               )
         )
         (setq inf (list xinfs yinfs xs ys sEnt nil nil))
        )
        ((= typ "CIRCLE")
         (setq p1  (trans (cdr (assoc 10 dat)) 0 1)
               x1 (car p1)
               y1 (cadr p1)
               rad (cdr (assoc 40 dat))
               xs  (list (+ x1 rad) (- x1 rad))
               ys  (list (+ y1 rad) (- y1 rad))
               xinfs (list (list (rtos x1 2 4) x1 (list y1)))
               yinfs (list (list (rtos y1 2 4) y1 (list x1)))
               inf (list xinfs yinfs xs ys nil (list p1 rad ent) nil)
         )
        )
        ((= typ "ARC")
         (setq p1 (trans (cdr (assoc 10 dat)) 0 1)
               rad (cdr (assoc 40 dat))
               xs (list (+ (car p1) rad) (- (car p1) rad))
               ys (list (+ (cadr p1) rad) (- (cadr p1) rad))
         )
         (setq inf (list nil nil xs ys nil nil (list p1 rad ent)))
        )
        ((= typ "INSERT")
         (setq p1  (trans (cdr (assoc 10 dat)) 0 1)
               x1 (car p1)
               y1 (cadr p1)
               xs  (list x1)
               ys  (list y1)
               xinfs (list (list (rtos x1 2 4) x1 (list y1)))
               yinfs (list (list (rtos y1 2 4) y1 (list x1)))
               inf (list xinfs yinfs xs ys nil (list p1 rad ent) nil)
         )
        )
  )
  inf
)

;;;
(defun ac-dimPtPair (p1 p2 cpt dir)
  (if (> (distance p1 cpt) (distance p2 cpt))
    (ac-dimOrd p1 (angle p2 p1) cpt dir)
    (ac-dimOrd p2 (angle p1 p2) cpt dir)
  )
)

;;;
(defun ac-dimPtSingle (pt cpt dir / v)
  (setq v (mapcar '- pt cpt))
  (cond        ((= dir "y")
         (if (> (car v) 0.0)
           (ac-dimOrd pt 0.0 cpt dir)
           (ac-dimOrd pt pi cpt dir)
         )
        )
        ((= dir "x")
         (if (> (cadr v) 0.0)
           (ac-dimOrd pt (* 0.5 pi) cpt dir)
           (ac-dimOrd pt (* 1.5 pi) cpt dir)
         )
        )
  )
)

;;;
(defun ac-dimInfs (infs cpt dir / a bs b1 b2 p1 p2)
  (foreach inf infs
    (setq a  (cadr inf)
          bs (vl-sort (nth 2 inf) '<)
    )
    (if        (= (length bs) 1)
      (cond ((= dir "x")
             (setq p1 (list a (car bs) 0.0))
             (ac-dimPtSingle p1 cpt dir)
            )
            ((= dir "y")
             (setq p1 (list (car bs) a 0.0))
             (ac-dimPtSingle p1 cpt dir)
            )
      )
      (cond ((= dir "x")
             (setq p1 (list a (car bs) 0.0)
                   p2 (list a (last bs) 0.0)
             )
             (if (equal p1 p2 1e-5)
               (ac-dimPtSingle p1 cpt dir)
               (ac-dimPtPair p1 p2 cpt dir)
             )
            )
            ((= dir "y")
             (setq p1 (list (car bs) a 0.0)
                   p2 (list (last bs) a 0.0)
             )
             (if (equal p1 p2 1e-5)
               (ac-dimPtSingle p1 cpt dir)
               (ac-dimPtPair p1 p2 cpt dir)
             )
            )
      )
    )
  )
)

;;;
;;; global variables: dd, posRec
;;; stPos: (x1 x2 y1 y2)
(defun ac-dimOrd (pt ang cpt dir / area pp px py dd2 pp2)
  (cond ((or (equal ang 0.0 0.001) (equal ang (* 2.0 pi) 0.001))
         (if (> (cadr pt) (cadr cpt))
           (setq area 7)
           (setq area 6)
         )
        )
        ((equal ang pi 0.001)
         (if (> (cadr pt) (cadr cpt))
           (setq area 5)
           (setq area 4)
         )
        )
        ((equal ang (* 0.5 pi) 0.001)
         (if (> (car pt) (car cpt))
           (setq area 3)
           (setq area 2)
         )
        )
        ((equal ang (* 1.5 pi) 0.001)
         (if (> (car pt) (car cpt))
           (setq area 1)
           (setq area 0)
         )
        )
  )
  (setq pp (nth area posRec))
  (cond        ((= area 0)
         (setq px (car pt)
               py (nth 2 stPos)
         )
         (if pp
           (progn
             (setq dd2 (- (- pp px) dd))
             (if (< dd2 0.0)
               (setq px (+ px dd2))
             )
           )
         )
         (setq pp2 px)
        )
        ((= area 1)
         (setq px (car pt)
               py (nth 2 stPos)
         )
         (if pp
           (progn
             (setq dd2 (- (- px pp) dd))
             (if (< dd2 0.0)
               (setq px (- px dd2))
             )
           )
         )
         (setq pp2 px)
        )
        ((= area 2)
         (setq px (car pt)
               py (nth 3 stPos)
         )
         (if pp
           (progn
             (setq dd2 (- (- pp px) dd))
             (if (< dd2 0.0)
               (setq px (+ px dd2))
             )
           )
         )
         (setq pp2 px)
        )
        ((= area 3)
         (setq px (car pt)
               py (nth 3 stPos)
         )
         (if pp
           (progn
             (setq dd2 (- (- px pp) dd))
             (if (< dd2 0.0)
               (setq px (- px dd2))
             )
           )
         )
         (setq pp2 px)
        )
        ((= area 4)
         (setq px (nth 0 stPos)
               py (cadr pt)
         )
         (if pp
           (progn
             (setq dd2 (- (- pp py) dd))
             (if (< dd2 0.0)
               (setq py (+ py dd2))
             )
           )
         )
         (setq pp2 py)
        )
        ((= area 5)
         (setq px (nth 0 stPos)
               py (cadr pt)
         )
         (if pp
           (progn
             (setq dd2 (- (- py pp) dd))
             (if (< dd2 0.0)
               (setq py (- py dd2))
             )
           )
         )
         (setq pp2 py)
        )
        ((= area 6)
         (setq px (nth 1 stPos)
               py (cadr pt)
         )
         (if pp
           (progn
             (setq dd2 (- (- pp py) dd))
             (if (< dd2 0.0)
               (setq py (+ py dd2))
             )
           )
         )
         (setq pp2 py)
        )
        ((= area 7)
         (setq px (nth 1 stPos)
               py (cadr pt)
         )
         (if pp
           (progn
             (setq dd2 (- (- py pp) dd))
             (if (< dd2 0.0)
               (setq py (- py dd2))
             )
           )
         )
         (setq pp2 py)
        )
  )
  ;; reorder posRec
  (setq        posRec (mapcar '(lambda        (i / r)
                          (if (= i area)
                            (setq r pp2)
                            (setq r (nth i posRec))
                          )
                          r
                        )
                       '(0 1 2 3 4 5 6 7)
               )
  )
  ;; dimension
  (command "DIMORDINATE" "none" pt dir "none" (list px py 0.0))
)

;;; dimension angle
(defun ac-dimAngle (ent / dat p1 p2 sPt ang ang2 ang3 str box v h s dis ePt1 ePt2 tmpPt box1 box2 ss1 ss2 n1 n2 ept)
  (setq        dat (entget ent)
        p1  (trans (cdr (assoc 10 dat)) 0 1)
        p2  (trans (cdr (assoc 11 dat)) 0 1)
        sPt (mapcar '(lambda (a b) (/ (+ a b) 2.0)) p1 p2)
        ang (angle p1 p2)
        ang2 (rem ang pi)
        ang3 (rem ang (/ pi 2.0))
  )
  (if (> ang3 (/ pi 4.0))
    (setq ang3 (- (/ pi 2.0) ang3))
  )
  (setq str (angtos ang3 0)
        str (strcat str "%%d")
        box (textbox (list (cons 1 str)))
        v   (mapcar '(lambda (a b) (- b a)) (car box) (cadr box))
        h   (/ (cadr v) 2.0)
        s   (getvar "DIMSCALE")
  )
  (if (= s 0.0)
    (setq s 1.0)
  )
  (setq        dis   (* s (getvar "DIMTXT") 5))
  (if (> ang2 (/ pi 2.0))
    (setq ePt1        (polar sPt (/ pi 6.0) dis)
          ePt2        (polar sPt (/ (* 7.0 pi) 6.0) dis)
          tmpPt        (list (nth 0 ePt1) (- (nth 1 ePt1) h) (nth 2 ePt1))
          box1        (list tmpPt (mapcar '+ tmpPt v))
          tmpPt        (list (nth 0 ePt2) (+ (nth 1 ePt2) h) (nth 2 ePt2))
          box2        (list (mapcar '- tmpPt v) tmpPt)
    )
    (setq ePt1        (polar sPt (/ (* 5.0 pi) 6.0) dis)
          ePt2        (polar sPt (/ (* 11.0 pi) 6.0) dis)
          tmpPt        (list (nth 0 ePt1) (+ (nth 1 ePt1) h) (nth 2 ePt1))
          box1        (list (mapcar '- tmpPt v) tmpPt)
          tmpPt        (list (nth 0 ePt2) (- (nth 1 ePt2) h) (nth 2 ePt2))
          box2        (list tmpPt (mapcar '+ tmpPt v))
    )
  )
  ;;
  (setq ss1 (ssget "C" (car box1) (cadr box1))
        ss2 (ssget "C" (car box2) (cadr box2))
  )
  (if ss1
    (setq n1 (sslength ss1))
    (setq n1 0)
  )
  (if ss2
    (setq n2 (sslength ss2))
    (setq n2 0)
  )
  (if (<= n1 n2)
    (setq ePt ePt1)
    (setq ePt ePt2)
  )
  ;;
  (command "LEADER" "none" sPt "none" ePt "" str "")
)

;;; dimension diameter & radius
;;;
(defun ac-dimCirArc(paks typ / pt rad ent rads rTxt sym dec dimEnt txtCen txtBox hv p1 p2 ang stAng wAng obj ang1 len)
  (foreach pak paks
    (setq pt  (nth 0 pak)
          rads (nth 1 pak)
          rad (last rads)
          ent (nth 2 pak)
          dec (getvar "DIMDEC")
          rTxt ""
    )
    (if (= typ "cir")
      (setq sym "%%c")
      (setq sym "R")
    )
    (foreach r (reverse (cdr rads))
      (setq rTxt (strcat ", " sym (rtos (* 2.0 r) 2 dec) rTxt))
    )
    (setq rTxt (strcat sym (rtos (* 2.0 (car rads)) 2 dec) rTxt))
    (if (= typ "cir")
      (progn
        (command "DIMDIAMETER" (list ent (polar pt 0.0 rad)) "t" rTxt "none" (polar pt 0.0 rad))
        (setq stAng (/ pi 4.0)
              wAng (+ pi 0.01)
        )
      )
      (progn
        (command "DIMRADIUS" (list ent (polar pt 0.0 rad)) "t" rTxt "none" (polar pt 0.0 rad))
        (setq obj (vlax-ename->vla-object ent)
              ang1 (vla-get-startAngle obj)
              len (vla-get-arcLength obj)
              wAng (/ len rad 2.0)
              stAng (+ ang1 wAng)
        )
      )
    )
    (setq dimEnt (entlast)
          txtCen (trans (cdr (assoc 11 (entget dimEnt))) 0 1)
          txtBox (textbox (list (cons 1 rTxt)))
          hv (mapcar '(lambda(a b) (/ (- b a) 2.0)) (car txtBox) (cadr txtBox))
          p1 (mapcar '- txtCen hv)
          p2 (mapcar '+ txtCen hv)
    )
    (entdel dimEnt)
    (setq ang (ac-findAng pt p1 p2 stAng wAng (/ pi 16.0)))
    (entdel dimEnt)
    (command "ROTATE" dimEnt "" "none" pt (angtos ang))
  )
)

;;;
(defun ac-reducePaks (paks / pt rad ent infs ptStr inf subPaks newPak newPaks)
  (foreach pak paks
    (setq pt (nth 0 pak)
          rad (nth 1 pak)
          ent (nth 2 pak)
          ptStr (strcat (rtos (car pt) 2 4) "," (rtos (cadr pt) 2 4))
          inf (assoc ptStr infs)
    )
    (if inf
      (setq infs (subst (append inf (list pak)) inf infs))
      (setq infs (cons (list ptStr pak) infs))
    )
  )
  (foreach inf infs
    (setq subPaks (vl-sort (cdr inf) '(lambda(a b) (< (cadr a) (cadr b))))
          newPak (list (caar subPaks) (mapcar 'cadr subPaks) (caddr (last subPaks)))
          newPaks (cons newPak newPaks)
    )
  )
  newPaks
)

;;;
(defun ac-findAng (cen p1 p2 stAng wAng dAng / p3 p4 pts ang ck dir ang2 pts2 ss fAng minS)
  (setq        p3  (list (car p1) (cadr p2) 0.0)
        p4  (list (car p2) (cadr p1) 0.0)
        pts (list p1 p3 p2 p4)
        ang 0.0
        ck T
  )
  (while ck
    (setq dir T)
    (repeat 2
      (if ck
        (progn
          (if dir
            (setq ang2 (+ stAng ang))
            (setq ang2 (- stAng ang))
          )
          (setq        pts2 (mapcar '(lambda (a)
                                (ac-newPos a cen ang2)
                              )
                             pts
                     )
                dir  (not dir)
                ss   (ssget "cp" pts2)
          )
          (if ss
            (progn
              (if fAng
                (if (< (sslength ss) minS)
                  (setq        fAng ang2
                        minS (sslength ss)
                  )
                )
                (setq fAng ang2
                      minS (sslength ss)
                )
              )
            ); -progn
            (setq fAng ang2
                  ck nil
            )
          ); -if
        ); -progn
      ); -if
    )
    (if        ck
      (setq ang        (+ ang dAng)
            ck        (<= ang wAng)
      )
    )
  )
  fAng
)

;;;
(defun ac-newPos(pt cen ang / pt2 x1 y1 x2 y2 c s)
  (setq pt2 (mapcar '- pt cen)
        x1 (car pt2)
        y1 (cadr pt2)
        c (cos ang)
        s (sin ang)
        x2 (- (* x1 c) (* y1 s))
        y2 (+ (* x1 s) (* y1 c))
        pt2 (mapcar '+ (list x2 y2 0.0) cen)
  )
  pt2
)
[/sell]

yuebirds

看看，是否能在工作中用得着……

sfqosk

谢谢分享  下载备用

ketxu

Please give some more detail or picture ^^

zhujinhui4715

看看，是否能在工作中用得着……

kmliro_2017

好资源，谢谢分享！！！！！