争取完美，《假尺寸检查2.0》源码奉献(已补上源码)

langjs

早期我贴了一个假尺寸检查程序，总觉得缺点什么，今天完善了一下，希望能更好用一些。
;;; ==========================================
;;; 名称: 《假尺寸检查》V2.0
;;; 功能：假尺寸(手动修改过的尺寸)数值显示红色
;;; 操作：运行jcc显示假尺寸,再次运行恢复不显示
;;;           连续不断运行闪烁。左键空拾取缩放，非
              空拾取修改尺寸数值，右键退出。
;;;                                     langjs
;;; ==========================================






;;; ==========================================
;;; 名称: 《假尺寸检查》v2.0
;;; 功能：假尺寸(手动修改过的尺寸)数值显示红色
;;; 操作：运行jcc显示假尺寸,再次运行恢复不显示
;;;       连续不断运行闪烁。支持修改假尺寸数值
;;;                                     langjs
;;; ==========================================
(defun c:jcc (/ #errjcc $orr ak bb bl col ctr dcl_pt dcl_re dclname ent er filen i jj k lb len1 len2 len3 n name name1 np1 np2 obj pt
  px py scale screen ss ss0 ss1 ss3 stream tempname u wzgd wzh xsize xx ysize yy
      )
  (defun getcursorpos (pt / ctr ysize screen scale xsize lb xx yy) ; 点坐标近似转像素坐标供对话框定位
    (setq ctr (getvar "VIEWCTR")
   ysize (getvar "VIEWSIZE")
   screen (getvar "SCREENSIZE")
   scale (/ (car screen) (cadr screen))
   xsize (* scale ysize)
   lb (list (- (car ctr) (/ xsize 2)) (- (cadr ctr) (/ ysize 2)))
   xx (- (car pt) (car lb))
   yy (- (cadr pt) (cadr lb))
    )
    (list (fix (+ 50 (* (/ xx xsize) (car screen)))) (fix (+ 120 (- (cadr screen) (* (/ yy ysize) (cadr screen))))))
  )
  (defun #errjcc (s)
    (if name1
      (redraw name1 4)
    )
    (command ".UNDO" "E")
    (c:jcc)
    (setq *error* $orr)
    (princ)
  )
  (setq $orr *error*)
  (setq *error* #errjcc)
  (vl-load-com)
  (setvar "cmdecho" 0)
  (command ".UNDO" "BE")
  (setq u t)
  (while u
    (if (progn
   (setq ss (ssadd)
  ss1 (ssadd)
   )
   (if (setq ss0 (ssget "X" '((0 . "DIMENSION"))))
     (progn
       (repeat (setq i (sslength ss0))
  (setq ent (ssname ss0 (setq i (1- i))))
  (if (= (vla-get-textcolor (vlax-ename->vla-object ent)) 1) ; 查找红色的假尺寸
    (setq ss (ssadd ent ss))
    (setq ss1 (ssadd ent ss1))
  )
       )
       (if (> (sslength ss) 0)
  (if (> (sslength ss1) 0)
    (setq col (vla-get-textcolor (vlax-ename->vla-object (ssname ss1 0))))
    (progn
      (setq col (getint "\n  输入尺寸恢复颜色[1红,2黄,3绿,4青,5蓝,6洋红,7白]:<3>"))
      (if (null col)
        (setq col 3)
      )
    )
  )
       )
     )
   )
   (> (sslength ss) 0)
)
      (progn
(setq u nil)
(repeat (setq i (sslength ss))
   (vlax-put-property (vlax-ename->vla-object (ssname ss (setq i (1- i)))) "textcolor" col) ; 颜色恢复
)
      )
      (if (setq ss (ssget "X" '((0 . "DIMENSION") (-4 . "<AND")
      (-4 . "<NOT")
      (1 . "")
      (-4 . "NOT>")
      (-4 . "<NOT")
      (1 . "*<>*")
      (-4 . "NOT>")
      (-4 . "AND>")
     )
     )
   )
(progn
   (princ (strcat "\n  找到" (itoa (sslength ss)) "个假尺寸并显示红色。"))
   (repeat (setq i (sslength ss))
     (vlax-put-property (vlax-ename->vla-object (ssname ss (setq i (1- i)))) "textcolor" 1) ; 显示红色
   )
   (setq obj (vlax-ename->vla-object (ssname ss 0)))
   (setq wzgd (vla-get-textheight obj)) ; 得到标注样式的文字高度
   (setq bl (vla-get-scalefactor obj)) ; 得到标注的调整比例
   (setq wzh (* wzgd bl))       ; 得到真正的文字高度
   (setq er 888
  jj 0
   )
   (while (or
     (= er 7)
     (= er 888)
   )
     (while (and
       (setq name (entsel "点空白缩放,点尺寸查看:<右键退出>"))
       (setq dcl_pt (getcursorpos (cadr name)))
       (setq name (car name))
       (= (cdr (assoc 0 (entget name))) "DIMENSION")
     )
       (progn
  (command "delay" "50")
  (setq ent (vlax-ename->vla-object name)
        len3 (vla-get-textoverride ent)
        len2 (vla-get-measurement ent)
  )
  (setq n 0
        len1 ""
  )
  (repeat (strlen len3)
    (setq k (substr len3 (setq n (+ 1 n))
      1
     )
   ak (ascii k)
    )
    (if (/= ak 123 ak 125)
      (setq len1 (strcat len1 k))
    )
  )
  (setq dclname (cond
    ((setq tempname (vl-filename-mktemp "jcc.dcl")
           filen (open tempname "w")
     )
      (foreach stream '("\n" "jcc:dialog {    label = \"检查尺寸\" ;\n"
         "    :edit_box { label = \"假值\" ; key = \"e01\" ;　width = 10 ;  }\n"
         "    :edit_box { label = \"真值\" ; key = \"e02\" ;　width = 10 ;  }\n"
         "    :row {\n" "      :button { label = \"修改\" ; key = \"e05\" ; }\n"
         "      :button { label = \"恢复\" ; key = \"e03\" ; is_default = true ;  }\n"
         "      :button { label = \"取消\" ; key = \"e04\" ;  is_cancel = true ;  }\n"
         "    }\n" "}\n"
        )
        (princ stream filen)
      )
      (close filen)
      tempname
    )
         )
  )
  (setq dcl_re (load_dialog dclname))
  (if (not (new_dialog "jcc" dcl_re "" dcl_pt))
    (exit)
  )
  (set_tile "e01" len1)
  (set_tile "e02" (rtos len2))
  (action_tile "e03" "(setq dcl_pt (done_dialog 1)) ")
  (action_tile "e05" "(setq k (get_tile \"e01\"  ) )(setq dcl_pt (done_dialog 2)) ")
  (setq bb (start_dialog))
  (if (= bb 2)
    (vla-put-textoverride ent k)
  )
  (if (= bb 1)
    (progn
      (setq ss3 (ssget "x" '((0 . "dimension") (-4 . "<or")
          (1 . "")
          (1 . "*<>*")
          (-4 . "or>")
         )
         )
      )
      (vla-put-textoverride ent "")
      (if ss3
        (setq col (vla-get-textcolor (vlax-ename->vla-object (ssname ss3 0))))
        (progn
   (setq col (getint "\n  输入尺寸恢复颜色[1红,2黄,3绿,4青,5蓝,6洋红,7白]:<3>"))
   (if (null col)
     (setq col 3)
   )
        )
      )
      (vlax-put-property ent "textcolor" col)
    )
  )
  (unload_dialog dcl_re)
  (vl-file-delete dclname)
  (princ "\n  ")
       )
     )
     (setq er (getvar "errno"))
     (if name1
       (redraw name1 4)
     )
     (if (= er 7)
       (progn
  (if (>= jj (sslength ss))
    (progn
      (setq jj 0)
      (alert (strcat "\n检查了" (itoa (sslength ss)) "个假尺寸,重新检查"))
    )
  )
  (setq name1 (ssname ss jj))
  (redraw name1 3)
  (setq np1 (cdr (assoc 11 (entget name1))))
  (setq px (car np1)
        py (cadr np1)
        np1 (list (- px (* wzh 40)) (- py (* wzh 20)) 0.0) ; 缩放窗口计算与字体高度关联
        np2 (list (+ px (* wzh 40)) (+ py (* wzh 20)) 0.0)
  )
  (command "zoom" "W" np1 np2)
  (setq jj (1+ jj))
  (princ "\n  ")
       )
     )
   )
)
(progn
   (setq u nil)
   (alert "\n本图未找到假尺寸!")
)
      )
    )
  )
  (command ".UNDO" "E")
  (setq *error* $orr)
  (princ)
)

Sonnenblumen

大师你好，我加载后，使用会提示以下信息，请教一下是什么原因啊？
调用(*push-error-using-command*)前无法从 *error* 调用(command)。
建议将(command)调用转换为(command-s)。

H-浩浩-H

能用 ， 如果尺寸是45   修改以后是345或者4568的话（就是假尺寸内出现原尺寸数值的话）     就检测不出来了

669423907

langjs 大师的高作，一定要支持啊！

langjs 大师方便帮看看一下我的求助帖吗？
http://bbs.mjtd.com/thread-92282-1-1.html

zdqwy19

cad的标注值可以修改其实不是什么好事

yjr111

建议加入焦点功能，并左键点击自动切换焦点，图大了找不到

429014673

sqqr

感激不尽啊

1993063

langjs 大师的高作，一定要支持啊！

langjs

不是大师，这样叫让我汗颜。只会三脚猫，不会高深的。

yshf

高手，向你致敬

fergus1987

谢谢楼主分享！