如何自动检查图纸中有无手改尺寸？

革天明

;此代码必须手动输入命令才能实现查找“手改尺寸”，如何实现“打开一张图纸就会弹出是否有手改尺寸”，记住，重点不在于“启动组”、“S::STARTUP " 、(c:xg)这些东西上面，因为程度的第一步在于选择图上的标注，不手动选择就会卡在选择这一步而进行不下去， 我们可以参考（command ”eraser" "all")这个句子，如何自动将所有的图元选中是关键（句子中过滤的部分了）。另外还有一个问题是当图纸中含有yellow颜色的图层时，修改后的标注颜色不变，也就是和其它的区别不开，最好是建一个金色的图层（rgb R:255 G:215 B:000)这样冷门的颜色来避免冲突。

1. ;============================================================================
   
2. (defun C:XG (/ Diment n cnt entn Dimn txtlst oldtxt newtxt I)
   
3.    (SETVAR CMDECHO_OLD (GETVAR "CMDECHO"))
   
4.    (SETVAR "CMDECHO" 0)
   
5.    (ssget)
   
6.    (SETQ Diment (SSGET "p" '((0 . "DIMENSION")))           
   
7.          n      (sslength Diment)
   
8.          cnt    0
   
9.          I      0
   
10.    )
    
11.    (PRINC (strcat "共有" (itoa N) " 个尺寸被选择。\n"))
    
12.    (if (not (tblseArch "layer" "YTM"))                  
    
13.                                                          
    
14.       (command ".-layer" "N" "YTM" "")
    
15.    )
    
16.    (WHILE (< I n)                                
    
17.       (PROGN (SETQ entn (ssname Diment I)
    
18.                    Dimn (entget entn)
    
19.              )
    
20.              (setq oldtxt (cdr (setq txtlst (assoc 1 Dimn))))
    
21.              (if (OR (WCMATCH OLDTXT "*<>*") (= OLDTXT ""))
    
22.                                                            
    
23.                 (terpri)
    
24.                 (progn (setq newtxt (strcat oldtxt "(<>)"))
    
25.                                                            
    
26.                        (SETQ DIMN (subst (cons 1 newtxt) txtlst Dimn))
    
27.                        (SETQ DIMN (SUBST (CONS 8 "YTM") (ASSOC 8 DIMN) DIMN))
    
28.                        (entmod Dimn)                    
    
29.                        (setq cnt (1+ cnt))
    
30.                 )
    
31.              )
    
32.              (SETQ I (1+ I))
    
33.       )
    
34.    )
    
35.    (COMMAND ".-LAYER" "c" "yellow" "YTM" "")
    
36.    (ALERT (strcat "合计查到 " (itoA cnt) " 个尺寸被手动改变！" "\n已放到YTM图层(黄色显示)"))
    
37.    (SETVAR "CMDECHO" CMDECHO_OLD)
    
38.    (GRTEXT)
    
39.    (princ)
    
40.    (GC)
    
41. )
    
42. ;============================================================================

;============================================================================<br /> (defun C:XG (/ Diment n cnt entn Dimn txtlst oldtxt newtxt I)<br />    (SETVAR CMDECHO_OLD (GETVAR "CMDECHO"))<br />    (SETVAR "CMDECHO" 0)<br />    (ssget)<br />    (SETQ Diment (SSGET "p" '((0 . "DIMENSION")))           <br />          n      (sslength Diment)<br />          cnt    0<br />          I      0<br />    )<br />    (PRINC (strcat "共有" (itoa N) " 个尺寸被选择。\n"))<br />    (if (not (tblseArch "layer" "YTM"))                  <br />                                                           <br />       (command ".-layer" "N" "YTM" "")<br />    )<br />    (WHILE (< I n)                                <br />       (PROGN (SETQ entn (ssname Diment I)<br />                    Dimn (entget entn)<br />              )<br />              (setq oldtxt (cdr (setq txtlst (assoc 1 Dimn))))<br />              (if (OR (WCMATCH OLDTXT "*<>*") (= OLDTXT ""))<br />                                                            <br />                 (terpri)<br />                 (progn (setq newtxt (strcat oldtxt "(<>)"))<br />                                                            <br />                        (SETQ DIMN (subst (cons 1 newtxt) txtlst Dimn))<br />                        (SETQ DIMN (SUBST (CONS 8 "YTM") (ASSOC 8 DIMN) DIMN))<br />                        (entmod Dimn)                    <br />                        (setq cnt (1+ cnt))<br />                 )<br />              )<br />              (SETQ I (1+ I))<br />       )<br />    )<br />    (COMMAND ".-LAYER" "c" "yellow" "YTM" "")<br />    (ALERT (strcat "合计查到 " (itoA cnt) " 个尺寸被手动改变！" "\n已放到YTM图层(黄色显示)"))<br />    (SETVAR "CMDECHO" CMDECHO_OLD)<br />    (GRTEXT)<br />    (princ)<br />    (GC)<br /> )<br /> ;============================================================================

vormittag

我的解决方法说明：
1、用(ssget "x" [filterlist])可以不用手动选择干预，选择图形数据库中所有对象。
2、我不认为标注内容带"<>"的就不是伪标，如果是标注内容是"1<>2"呢？所以只要标注图元组码1不为空字符串，就认为是伪标。
3、新建不同颜色的图层不一定合适，很难保证和正确的标注有强烈的反差。如果加上红色的文字背景，则二者的反差就大了，几乎不会有人设置标注样式的时候会添加标注文字背景。

所以我的解决方案是这样的：

2. (defun c:wbxs( / ss i ename)
   
3.     (setq ss (ssget "X" '((0 . "DIMENSION")(-4 . "<NOT") (1 . "")(-4 . "NOT>")))
   
4.              i  0
   
5.     );setq
   
6.     (if (/= nil ss)
   
7.         (repeat (sslength ss)
   
8.               (setq ename (ssname ss i)
   
9.                        i          (1+ i)
   
10.               );setq
    
11.               (set_pseudodim ename)
    
12.          );repeat
    
13.      );if
    
14.     (princ)
    
15. )
    
16. ;;;设置伪标显示扩展数据
    
17. (defun set_pseudodim (ename / nel l ll)
    
18.     (setq ll (list (cons 1002 "}"))
    
19.               l  (cons 1070 2)
    
20.                   ll (cons l ll)
    
21.                   l  (cons 1070 69)
    
22.                   ll (cons l ll)
    
23.                   l  (cons 1070 1)
    
24.                   ll (cons l ll)
    
25.                   l  (cons 1070 70)
    
26.                   ll (cons l ll)
    
27.                   l  (cons 1002 "{")
    
28.                   ll (cons l ll)
    
29.                   l  (cons 1000 "DSTYLE")
    
30.                   ll (cons l ll)
    
31.                   ll (list -3 (cons "ACAD" ll))
    
32.                   el (entget ename)
    
33.                   nel (cons ll el)
    
34.         );setq
    
35.         (regapp "ACAD")
    
36.         (entmod nel)
    
37. )

(defun c:wbxs( / ss i ename)<br />     (setq ss (ssget "X" '((0 . "DIMENSION")(-4 . "<NOT") (1 . "")(-4 . "NOT>"))) <br />              i  0<br />     );setq<br />     (if (/= nil ss)<br />         (repeat (sslength ss)<br />               (setq ename (ssname ss i) <br />                        i          (1+ i)<br />               );setq<br />               (set_pseudodim ename)<br />          );repeat<br />      );if<br />     (princ)<br /> )<br /> ;;;设置伪标显示扩展数据<br /> (defun set_pseudodim (ename / nel l ll)<br />     (setq ll (list (cons 1002 "}"))<br />               l  (cons 1070 2)<br />                   ll (cons l ll)<br />                   l  (cons 1070 69)<br />                   ll (cons l ll)<br />                   l  (cons 1070 1)<br />                   ll (cons l ll)<br />                   l  (cons 1070 70)<br />                   ll (cons l ll)<br />                   l  (cons 1002 "{")<br />                   ll (cons l ll)<br />                   l  (cons 1000 "DSTYLE")<br />                   ll (cons l ll)<br />                   ll (list -3 (cons "ACAD" ll))<br />                   el (entget ename)<br />                   nel (cons ll el)<br />         );setq<br />         (regapp "ACAD")<br />         (entmod nel)<br /> )

如果要恢复标注的样式，去掉文字背景，用下面的代码：

2. ;;;恢复样式的方法
   
3. (defun c:bzyshf ( / ss i ename ell)
   
4.     (setq ss (ssget "X" '((0 . "DIMENSION") (-3 ("ACAD"))))
   
5.              i 0
   
6.     );setq
   
7.     (if (/= nil ss)
   
8.         (repeat (sslength ss)
   
9.                (setq ename (ssname ss i)
   
10.                         i          (1+ i)
    
11.                );setq
    
12.                (removexdata ename "ACAD")
    
13.         );repeat
    
14.      );if
    
15.         (princ)
    
16. )
    
17. ;;; 删除指定扩展数据
    
18. (defun removexdata(ename appid / id idlist ell1 ell2)
    
19.     (setq id  (tblnext "APPID" 'T)
    
20.              idlist nil
    
21.     );setq
    
22.     (while id
    
23.          (setq idlist (cons (cdr (assoc 2 id)) idlist)
    
24.                  id     (tblnext "APPID")
    
25.           );setq
    
26.     );while
    
27.     (if idlist
    
28.         (progn
    
29.             (setq ell1 (entget ename idlist)
    
30.                      ell2 (assoc -3 ell1)
    
31.             );setq
    
32.             (if (assoc appid (cdr ell2))
    
33.                 (progn
    
34.                      (setq ell2 (cdr ell2)
    
35.                            ell2 (append (list -3)
    
36.                               (reverse (cdr (member (assoc appid ell2) (reverse ell2))))
    
37.                                (cdr (member (assoc appid ell2) ell2))
    
38.                               );append
    
39.                               ell1 (subst ell2 (assoc -3 ell1) ell1)
    
40.                        );setq
    
41.                        (entdel ename)
    
42.                        (entmake ell1)
    
43.                  );progn
    
44.             );if
    
45.         );progn
    
46.     );if
    
47. )

;;;恢复样式的方法<br /> (defun c:bzyshf ( / ss i ename ell)<br />     (setq ss (ssget "X" '((0 . "DIMENSION") (-3 ("ACAD")))) <br />              i 0<br />     );setq<br />     (if (/= nil ss)<br />         (repeat (sslength ss)<br />                (setq ename (ssname ss i) <br />                         i          (1+ i)<br />                );setq<br />                (removexdata ename "ACAD")<br />         );repeat<br />      );if<br />         (princ)<br /> )<br /> ;;; 删除指定扩展数据<br /> (defun removexdata(ename appid / id idlist ell1 ell2)<br />     (setq id  (tblnext "APPID" 'T)<br />              idlist nil<br />     );setq<br />     (while id <br />          (setq idlist (cons (cdr (assoc 2 id)) idlist)<br />                  id     (tblnext "APPID")<br />           );setq<br />     );while<br />     (if idlist<br />         (progn<br />             (setq ell1 (entget ename idlist)<br />                      ell2 (assoc -3 ell1)<br />             );setq<br />             (if (assoc appid (cdr ell2))<br />                 (progn <br />                      (setq ell2 (cdr ell2) <br />                            ell2 (append (list -3)<br />                               (reverse (cdr (member (assoc appid ell2) (reverse ell2))))<br />                                (cdr (member (assoc appid ell2) ell2))<br />                               );append<br />                               ell1 (subst ell2 (assoc -3 ell1) ell1)<br />                        );setq<br />                        (entdel ename)<br />                        (entmake ell1)<br />                  );progn<br />             );if<br />         );progn<br />     );if<br /> )

革天明

悬赏不是目的，希望能有高人将这个问题完美解决，这样我们就不用对手改尺寸而烦恼了！

byghbcx

vla-get-textoverride可以判断

AMTONNY

这个有点意思，先占个位置

革天明

;============================================================================
(defun C:XG (/ Diment n cnt entn Dimn txtlst oldtxt newtxt I)
   (SETVAR "CMDECHO" 0)
   ;(ssget)
   ;(SETQ Diment (SSGET "p" '((0 . "DIMENSION")))
   (SETQ Diment (ssget "X" '((0 . "DIMENSION")(-4 . "<NOT") (1 . "")(-4 . "NOT>")))
         
         n      (sslength Diment)
         cnt    0
         I      0
   )
   (PRINC (strcat "共有" (itoa N) " 个尺寸被选择。\n"))
   (if (not (tblseArch "layer" "YTM"))                  
                                                         
      (command ".-layer" "N" "YTM" "")
   )
   
   (WHILE (< I n)                                
      (PROGN (SETQ entn (ssname Diment I)
                   Dimn (entget entn)
             )
             (setq oldtxt (cdr (setq txtlst (assoc 1 Dimn))))
             (if (OR (WCMATCH OLDTXT "*<>*") (= OLDTXT ""))
                                                           
                (terpri)
                (progn (setq newtxt (strcat oldtxt "(<>)"))
                                                           
                       (SETQ DIMN (subst (cons 1 newtxt) txtlst Dimn))
                       (SETQ DIMN (SUBST (CONS 8 "YTM") (ASSOC 8 DIMN) DIMN))
                       (entmod Dimn)                    
                       (setq cnt (1+ cnt))
                )
             )
             (SETQ I (1+ I))
      )
   )
   ;(COMMAND ".-LAYER" "c" "YELLOW"  "YTM" "")原来在这个位置
   (COMMAND ".-LAYER" "c" "T" "255,215,0" "YTM" "")
   (IF (> cnt 0)
       (ALERT (strcat "合计查到 " (itoA cnt) " 个尺寸被手动改变！" "\n已放到YTM图层(金黄色显示)"))
   )
   (SETVAR "CMDECHO" 1)
   (GRTEXT)
   (princ)
   (GC)
)
(C:XG)
;--------------------------------------------------------------------------------------------------
;|暂时修改到这一步了，可以自动选择所有标，对于无手改尺寸的，不弹出提示，但如何醒目地显示什么地方改动了还不能实现。如果图纸中图层很少，可以正确执行，但附件中的却不能得到想要的结果，请大侠指教。|;

革天明

这里面是不能正确运行的图纸，不知道是什么原因造成了这段代码不能正确运行？

革天明

;本程序用于自动检查图纸中是否有手工修改标尺寸的问题，无手改尺寸不提示
;对于手工添加直径符号等不认为是手改尺寸
;本程序由YTM、vormittag、ZZXXQQ合作完成，在此向二位表示感谢。2011.10.15
;============================================================================
(defun C:XG (/ Diment n cnt entn Dimn txtlst oldtxt newtxt I)
(SETVAR "CMDECHO" 0)
(setvar "CECOLOR" "BYLAYER")
(setvar "DIMCLRD" 0)
(setvar "DIMCLRE" 0)
(setvar "DIMCLRT" 0)
(command "-DIMSTYLE" "S" (getvar "DIMSTYLE") "Y")
(SETQ Diment (ssget "X" '((0 . "DIMENSION")(-4 . "<NOT") (1 . "")(-4 . "NOT>")))
       n      (sslength Diment)
       cnt    0
       I      0)
(PRINC (strcat "共有" (itoa N) " 个尺寸被选择。\n"))
(command ".-layer" "M" "YTM" "")
(command ".CHPROP" Diment "" "C" "BYLAYER" "")
(WHILE (< I n)                                
  (SETQ entn (ssname Diment I)
        Dimn (entget entn))
  (setq oldtxt (cdr (setq txtlst (assoc 1 Dimn))))
  (if (OR (WCMATCH OLDTXT "*<>*") (= OLDTXT ""))
   (terpri)
  (progn
   (setq newtxt (strcat oldtxt "(<>)"))
   (SETQ DIMN (subst (cons 1 newtxt) txtlst Dimn))
   (SETQ DIMN (SUBST (CONS 8 "YTM") (ASSOC 8 DIMN) DIMN))
   (entmod Dimn)
   (setq cnt (1+ cnt))
  ))
  (SETQ I (1+ I))
)
(COMMAND ".-LAYER" "c" "T" "255,215,0" "YTM" "")
(IF (> cnt 0)
  (ALERT (strcat "合计查到 " (itoA cnt) " 个尺寸被手动改变！" "\n已放到YTM图层(金黄色显示)"))
)
(SETVAR "CMDECHO" 1)
(GRTEXT)
(princ)
(GC)
)
(C:XG)
;--------------------------------------------------------------------------------------------------

革天明

想请教一下，为什么有时候代码为染色，还有滚动条，有时候没有？我不太懂

ZZXXQQ

游客，本帖隐藏的内容需要发帖数高于 5 才可浏览，你当前发帖数只有 0