图纸尺寸漏标检查v1.0

langjs

运行后对漏标尺寸的图元进行亮显，提醒进行补齐标注
目前只适用横平竖直的线图纸，不适用倾斜线


;;;  =================================================
;;;   图纸尺寸漏标检查v1.0
;;;   只限横平竖直的线图纸，不适用倾斜线
;;;   运行后对漏标尺寸的图元进行亮显，提醒进行补齐标注
;;;   作者：langjs                   日期:2020年9月
;;;  =================================================
(defun c:qq (/ clst ent i lst lst1 m n nalst nalst1 name nbak p pd pt1 pt2 ptn0 ptn1 ptn2 ptn3 ptn4 ptxlst ptylst px py r rlst ss ss1
        ssxlst ssylst uxlst uxzlst uylst uyzlst w w1 xma xma1 yma yma1 znaxlst znaylst zxlst zylst)
  (defun equlst (i lst / n p)        ; 判断元素是否在表中
    (setq p nil)
    (foreach n lst
      (if (equal i n 0.0001)
(setq p t))) p)
  (defun liness (ss lst / ent i name ss1) ;  线型过滤
    (setq ss1 (ssadd))
    (repeat (setq i (sslength ss))
      (setq name (ssname ss (setq i (1- i))))
      (setq ent (entget name))
      (if (or (member (cdr (assoc 6 ent)) lst)
     (and (not (cdr (assoc 6 ent)))
       (member (cdr (assoc 6 (tblsearch "layer" (cdr (assoc 8 ent))))) lst)))
(setq ss1 (ssadd name ss1)))) ss1)
  (foreach n (list ptxlst ptylst rlst clst ssxlst ssylst zxlst zylst znaxlst znaylst uxlst uylst)
    (setq n '()))
  (setq p t)
  (if (setq pt1 (getpoint "\n指定角点:"))
    (if (setq pt2 (getcorner pt1 "\n指定对角点:"))
      (progn
(if (setq ss (ssget "W" pt1 pt2 '((0 . "LINE,ARC,CIRCLE,LWPOLYLINE,DIMENSION"))))
   (repeat (setq i (sslength ss))
     (redraw (ssname ss (setq i (1- i))) 4)))
(if (setq ss (ssget "w" pt1 pt2 '((0 . "line")))) ; 处理中心线标注尺寸
   (progn  (setq ss (liness ss (list "ACAD_ISO04W100" "ACAD_ISO08W100" "ACAD_ISO10W100" "CENTER" "CENTER2" "CENTERX2" "DASHDOT"
          "DASHDOTX2" "G" "J" "ZX")))
     (repeat (setq i (sslength ss))
       (setq name (ssname ss (setq i (1- i)))  ent (entget name)
      ptn1 (cdr (assoc 10 ent))  ptn2 (cdr (assoc 11 ent)))
       (if (equal (car ptn1) (car ptn2) 0.0001)
  (setq zxlst (cons (car ptn1) zxlst)))
       (if (equal (cadr ptn1) (cadr ptn2) 0.0001)
  (setq zylst (cons (cadr ptn1) zylst))))))
(if (setq ss (ssget "W" pt1 pt2 '((0 . "DIMENSION")))) ; 先把标注进行处理
   (repeat (setq i (sslength ss))
     (setq name (ssname ss (setq i (1- i)))  ent (entget name))
     (cond
       ((= (cdr (assoc 100 (reverse ent))) "AcDbDiametricDimension") ; 直径标注
  (setq rlst (cons (* 0.5 (cdr (assoc 42 ent))) rlst)))
       ((= (cdr (assoc 100 (reverse ent))) "AcDbRadialDimension") ; 半径标注
  (setq rlst (cons (cdr (assoc 42 ent)) rlst)))
       (t (setq ptn0 (cdr (assoc 10 ent))  ptn1 (cdr (assoc 13 ent)) ptn2 (cdr (assoc 14 ent)))
  (cond  ((equal (car ptn0) (car ptn2) 0.0001) ; 线性水平标注
      (setq ptxlst (cons (car ptn1) ptxlst)  ptxlst (cons (car ptn2) ptxlst))
      (setq ssxlst (cons name ssxlst))
      (if (equlst (* 0.5 (+ (car ptn1) (car ptn2))) zxlst)
        (setq uxlst (cons (car ptn1) uxlst)  uxlst (cons (car ptn2) uxlst)  znaxlst (cons name znaxlst))))
    ((equal (cadr ptn0) (cadr ptn2) 0.0001) ; 线性垂直标注
      (setq ptylst (cons (cadr ptn1) ptylst)  ptylst (cons (cadr ptn2) ptylst))
      (setq ssylst (cons name ssylst))
      (if (equlst (* 0.5 (+ (cadr ptn1) (cadr ptn2))) zylst)
        (setq uylst (cons (cadr ptn1) uylst) uylst (cons (cadr ptn2) uylst)  znaylst (cons name znaylst)))))))))
(if (setq ss (ssget "w" pt1 pt2 '((0 . "line")))) ; 处理中心线标注尺寸
   (progn (setq ss (liness ss (list "ACAD_ISO04W100" "ACAD_ISO08W100" "ACAD_ISO10W100" "CENTER" "CENTER2" "CENTERX2" "DASHDOT"
          "DASHDOTX2" "G" "J" "ZX")))
     (repeat (setq i (sslength ss))
       (setq name (ssname ss (setq i (1- i)))   ent (entget name)
      ptn1 (cdr (assoc 10 ent))   ptn2 (cdr (assoc 11 ent)))
       (if (equal (car ptn1) (car ptn2) 0.0001)
  (if (not (equlst (car ptn1) ptxlst))
    (progn (redraw name 3)  (setq p nil))))
       (if (equal (cadr ptn1) (cadr ptn2) 0.0001)
  (if (not (equlst (cadr ptn1) ptylst))
    (progn (redraw name 3) (setq p nil)))))))
(if (setq ss (ssget "W" pt1 pt2 '((0 . "ARC")))) ; 检查圆弧是否标注
   (progn  (setq ss (liness ss '("Continuous")))
     (repeat (setq i (sslength ss))
       (setq name (ssname ss (setq i (1- i)))  clst (cons name clst)
      ent (entget name) ptn0 (cdr (assoc 40 ent)))
       (if (not (equlst ptn0 rlst))
  (progn  (redraw name 3) (setq p nil))))))
(if (setq ss (ssget "W" pt1 pt2 '((0 . "LINE")))) ; 检查直线是否标注
   (progn   (setq ss (liness ss '("Continuous")))
     (repeat (setq i (sslength ss))
       (setq name (ssname ss (setq i (1- i)))  ent (entget name)
      ptn1 (cdr (assoc 10 ent)) ptn2 (cdr (assoc 11 ent)))
       (foreach n clst
  (setq ent (entget n)  r (cdr (assoc 40 ent))  ptn0 (cdr (assoc 10 ent))
        ptn3 (polar ptn0 (cdr (assoc 50 ent)) r)  ptn4 (polar ptn0 (cdr (assoc 51 ent)) r))
  (cond  ((or (equal ptn1 ptn3 0.0001) (equal ptn1 ptn4 0.0001))
      (setq ptn1 (polar ptn1 (angle ptn2 ptn1) r)))
    ((or (equal ptn2 ptn3 0.0001) (equal ptn2 ptn4 0.0001))
      (setq ptn2 (polar ptn2 (angle ptn1 ptn2) r)))))
       (if (not (and (equlst (car ptn1) ptxlst) (equlst (car ptn2) ptxlst)
    (equlst (cadr ptn1) ptylst) (equlst (cadr ptn2) ptylst)))
  (progn  (redraw name 3) (setq p nil))))))
(if (setq ss (ssget "W" pt1 pt2 '((0 . "CIRCLE")))) ; 检查圆是否标注
   (progn   (setq ss (liness ss '("Continuous")))
     (repeat (setq i (sslength ss))
       (setq name (ssname ss (setq i (1- i)))  ent (entget name)
      ptn1 (cdr (assoc 10 ent))  ptn2 (cdr (assoc 40 ent)))
       (if (not (and (equlst (car ptn1) ptxlst) (equlst (cadr ptn1) ptylst) (equlst ptn2 rlst)))
  (progn  (redraw name 3) (setq p nil))))))
(if (setq ss (ssget "W" pt1 pt2 '((0 . "LWPOLYLINE")))) ; 检查多段线是否标注
   (progn  (setq ss (liness ss '("Continuous")))
     (repeat (setq i (sslength ss))
       (setq name (ssname ss (setq i (1- i)))  ent (entget name))
       (foreach n ent
  (if (= (car n) 10)
    (progn (setq ptn0 (cdr n))
      (if (not (and (equlst (car ptn0) ptxlst) (equlst (cadr ptn0) ptylst)))
        (progn(redraw name 3)(setq p nil)))))))))
(setq px 0)
(defun lianx (name ssxlst / ent lst n nalst nalst1 pd ptn1 ptn2) ; 以下程序检查横向标注的定位尺寸并亮显
   (setq lst '() nalst (list name)nalst1 (vl-remove name ssxlst) ent (entget name)
  lst (cons (car (cdr (assoc 13 ent))) lst)lst (cons (car (cdr (assoc 14 ent))) lst)pd t)
   (while (and   pd  (> (length nalst1) 0))
     (setq pd nil)
     (foreach n nalst1
       (setq ent (entget n) ptn1 (car (cdr (assoc 13 ent)))  ptn2 (car (cdr (assoc 14 ent))))
       (if (or  (equlst ptn1 lst) (equlst ptn2 lst))
  (setq nalst1 (vl-remove n nalst1)   nalst (cons n nalst)
        lst (cons ptn1 lst)  lst (cons ptn2 lst)  pd t))))
   (list nalst nalst1))
(setq uxzlst '())
(foreach n znaxlst
   (setq lst (lianx n ssxlst)uxzlst (cons (car lst) uxzlst)ssxlst (cadr lst)))
(setq uxlst '())
(while ssxlst
   (setq name (car ssxlst)lst (lianx name ssxlst)uxlst (cons (car lst) uxlst)
  ssxlst (cadr lst)))
(defun xma (lst / lst1 m n nbak w w1)
   (setq w 0.0)
   (if lst (progn (foreach n lst (setq lst1 '())
  (foreach m n
    (setq lst1 (cons (car (cdr (assoc 13 (entget m)))) lst1)
   lst1 (cons (car (cdr (assoc 14 (entget m)))) lst1)))
  (setq lst1 (vl-sort lst1 '<)  w1 (- (last lst1) (car lst1)))
  (if (> w1 w) (setq w w1 nbak n)))))
   (list w nbak))
(setq xma1 (xma uxlst)  xma (xma uxzlst)  px t)
(if (> (car xma) (car xma1))
   (foreach n uxlst (foreach m n (if m(setq px nil)) (redraw m 3)))
   (progn   (setq uxlst (vl-remove (cadr xma1) uxlst))
     (foreach n uxlst (foreach m n(if m (setq px nil))(redraw m 3)))))
(defun liany (name ssylst / ent lst n nalst nalst1 pd ptn1 ptn2) ; 以下程序检查纵向向标注的定位尺寸并亮显
   (setq lst '() nalst (list name)nalst1 (vl-remove name ssylst) ent (entget name)
  lst (cons (cadr (cdr (assoc 13 ent))) lst)lst (cons (cadr (cdr (assoc 14 ent))) lst)pd t)
   (while (and   pd  (> (length nalst1) 0))
     (setq pd nil)
     (foreach n nalst1
       (setq ent (entget n) ptn1 (cadr (cdr (assoc 13 ent))) ptn2 (cadr (cdr (assoc 14 ent))))
       (if (or (equlst ptn1 lst) (equlst ptn2 lst))
  (setq nalst1 (vl-remove n nalst1)  nalst (cons n nalst)   lst (cons ptn1 lst)
        lst (cons ptn2 lst)     pd t))))
   (list nalst nalst1))
(setq uyzlst '())
(foreach n znaylst
   (setq lst (liany n ssylst)uyzlst (cons (car lst) uyzlst)ssylst (cadr lst)))
(setq uylst '())
(while ssylst
   (setq name (car ssylst)lst (liany name ssylst)uylst (cons (car lst) uylst)ssylst (cadr lst)))
(defun yma (lst / lst1 m n nbak w w1)
   (setq w 0.0)
   (if lst   (progn
       (foreach n lst
  (setq lst1 '()) (foreach m n
    (setq lst1 (cons (cadr (cdr (assoc 13 (entget m)))) lst1)
   lst1 (cons (cadr (cdr (assoc 14 (entget m)))) lst1)))
  (setq lst1 (vl-sort lst1 '<))
  (setq w1 (- (last lst1) (car lst1)))
  (if (> w1 w)  (setq w w1 nbak n)))))
   (list w nbak))
(setq yma1 (yma uylst)   yma (yma uyzlst)   py t)
(if (> (car yma) (car yma1))
   (foreach n uylst
     (foreach m n  (if m (setq py nil)) (redraw m 3)))
   (progn   (setq uylst (vl-remove (cadr yma1) uylst))
     (foreach n uylst
       (foreach m n (if m  (setq py nil))(redraw m 3)))))
(if (and  p   px  py)
   (alert "尺寸检查完毕，完整！")
   (alert "请检查亮显的图元和尺寸:\n\n直   线:  检查长度、横、纵方向是否标齐\n中心线:  检查横、纵方向是否标齐\n圆亮显:  检查直径、圆心的横、纵方向是否标齐\n圆   弧:  检查圆弧半径是否标齐\n标   注:  检查定位尺寸是否标齐")
))))
  (princ)
)

lrd1861

songyujie928

支持大佬，学习一下

czb203

支持大佬，学习一下

yaokui25

谢谢 langjs 大师提供这么好的作品！

xmq1103

支持大佬，学习一下

fxlt619

谢谢 langjs 大师提供这么好的作品！

664571221

大师新作牛逼class

maiko

感谢楼主分享,收下了