悬赏标注检查

langjs

;;; ======================================
;;; 名称: 尺寸检查
;;; 功能：尺寸起末点不在线端点数值显示红色
;;; ======================================
(defun c:aa (/ ent i lst name p p13 p14 ss ss0)
  (setvar "cmdecho" 0)
  (vl-load-com)
  (setq lst '()        p t  )
  (if (setq ss0 (ssget "X" '((0 . "DIMENSION"))))
    (repeat (setq i (sslength ss0))
      (setq name (ssname ss0 (setq i (1- i))))
      (if (= (vla-get-textcolor (vlax-ename->vla-object name)) 1)
        (setq ss (vlax-put-property (vlax-ename->vla-object name) "textcolor" 256)  p nil)
      ) )
  )
  (if p
    (progn (if (setq ss (ssget "X" '((0 . "ARC,CIRCLE"))))
        (repeat (setq i (sslength ss))
          (setq ent (entget (ssname ss (setq i (1- i)))) lst (cons (cdr (assoc 10 ent)) lst)          )
          (if (assoc 50 ent) (setq lst (cons (polar (cdr (assoc 10 ent)) (cdr (assoc 50 ent)) (cdr (assoc 40 ent))) lst)))
          (if (assoc 51 ent) (setq lst (cons (polar (cdr (assoc 10 ent)) (cdr (assoc 51 ent)) (cdr (assoc 40 ent))) lst)))
        ))
      (if (setq ss (ssget "X" '((0 . "DIMENSION"))))
        (repeat (setq i (sslength ss))
          (setq name (ssname ss (setq i (1- i))) p13 (cdr (assoc 13 (entget name))) p14 (cdr (assoc 14 (entget name))))
          (if (and(or (member p13 lst) (ssget "c" p13 p13 '((0 . "LWPOLYLINE,LINE,PLINE"))))
                  (or (member p14 lst) (ssget "c" p14 p14 '((0 . "LWPOLYLINE,LINE,PLINE"))))
              )
            (princ)
            (vlax-put-property (vlax-ename->vla-object name) "textcolor" 1)
          ))))
  )
  (princ)
)

无欲神

看看是不是非常好啊

461045462

谢谢11楼的分享
收藏了，学习学习
谢谢

adc

langjs 发表于 2012-3-11 11:45
一个类似作用的
;;; ======================================
;;; 名称: 尺寸检查

如果不在端点上，能不能自动移动到端点上

chenqiang26

刚去试了下，如果标注半径直径也会变成红色。。。。还有能不能增加有多少个标注变成了红色，这样好找一点

chenqiang26

langjs 发表于 2012-3-13 12:59
;;; ======================================
;;; 名称: 尺寸检查
;;; 功能：尺寸起末点不在线端点数值显 ...

刚去试了下，如果标注半径直径也会变成红色。。。。还有能不能增加有多少个标注变成了红色，这样好找一点

cghdy

精度控制的太细吗，运行一下全显红

00放飞梦想00

楼主能把这个代码发我一下吗？