炒冷饭：字编辑器(改过变色，不改不变）

yjr111

flytoday发给我的网上的程序，今天有空完善了一下，一次设定即可，中途可变更修改颜色      

2. edit:dialog
   
3. {
   
4.   label="文字编辑";
   
5.   :edit_box
   
6.   {
   
7.     label="文字:";
   
8.     key="edit";
   
9.     edit_width=40;
   
10.     //height=2;
    
11.     //fixed_height=true;
    
12.     allow_accept=true;
    
13.   }
    
14.   :row
    
15.   {
    
16.     :text{value="修改颜色:";width=5;}
    
17.     :image_button{height=2;key="tucengcolor";width=4;}
    
18.     ok_cancel;
    
19.   }
    
20.   spacer;
    
21. }

edit:dialog<br /> {<br />   label="文字编辑";<br />   :edit_box<br />   {<br />     label="文字:";<br />     key="edit";<br />     edit_width=40;<br />     //height=2;<br />     //fixed_height=true;<br />     allow_accept=true;<br />   }<br />   :row<br />   {<br />     :text{value="修改颜色:";width=5;}<br />     :image_button{height=2;key="tucengcolor";width=4;}<br />     ok_cancel;<br />   }<br />   spacer;<br /> }

2. (defun newerr()
   
3.   (setq *error* olderr esel nil edata nil d nil new nil do nil ss nil name nil)
   
4.   (command "undo" "e")
   
5.   (princ)
   
6. )
   
7. 
   
8. (defun c:ue(/ esel edata enme id new do ss name)
   
9.   (setq olderr *error* *error* newerr )
   
10.   (if (not colorname )(setq colorname 1)colorname)
    
11.   (gc)
    
12.   (setvar "cmdecho" 0)
    
13.   (command "undo" "be")
    
14.   (VL-LOAD-COM)
    
15.   (setq AcadObject(vlax-get-acad-object)
    
16.         AcadDocument(vla-get-ActiveDocument Acadobject)
    
17.         mSpace(vla-get-ModelSpace Acaddocument)
    
18. )
    
19. (defun getdata14(color / ccc);;;定义获取acad标准颜色函数
    
20.     (setq ccc(acad_colordlg color t))
    
21.     (if (not ccc)(setq ccc color))
    
22.     ccc
    
23.     )
    
24.   (defun c_img(key color);;;定义初始化颜色图像按钮函数
    
25.     (if color
    
26.       (progn
    
27.         (start_image key)
    
28.         (fill_image 0 0 (dimx_tile key)(dimy_tile key)color)
    
29.         (end_image)
    
30.         )
    
31.       )
    
32.     )
    
33.   (setq esel (nentsel "\n选择文字"))
    
34.   (setq edata (entget (car esel)))
    
35.   (setq oldwenzi (cdr(assoc 1 edata)))
    
36.   (if
    
37.     (and
    
38.       (> (length esel) 2)
    
39.       (= (cdr (assoc 0 (entget (car esel)))) "MTEXT")
    
40.       (= (cdr (assoc 0 (entget (car (last esel))))) "DIMENSION")
    
41.     )
    
42.     (setq enme (car (last esel)) edata (entget enme))
    
43.   )
    
44.   (cond
    
45.     (
    
46.       (or
    
47.         (= (cdr (assoc 0 edata)) "TEXT")
    
48.         (= (cdr (assoc 0 edata)) "MTEXT")
    
49.         (= (cdr (assoc 0 edata)) "DIMENSION")
    
50.         (= (cdr (assoc 0 edata)) "ATTRIB")
    
51.         (= (cdr (assoc 0 edata)) "ATTDEF")
    
52.       )
    
53.       (if (> (setq id (load_dialog "ue.dcl")) 0)
    
54.         (if (new_dialog "edit" id)
    
55.           (progn
    
56.              (cond
    
57.               (
    
58.                 (= (cdr (assoc 0 edata)) "DIMENSION")
    
59.                 (set_tile "edit" (vl-string-subst  "" "\\A1;" (cdr (assoc 1 (entget (car esel))))))
    
60.                 (set_tile "error" "尺寸文字")
    
61.               )
    
62.               (
    
63.                 (and (> (length esel) 2)(= (cdr (assoc 0 (entget (car (last esel))))) "INSERT"))
    
64.                 (set_tile "edit" (cdr (assoc 1 edata)))
    
65.                 (set_tile "error" "块中文字")
    
66.               )
    
67.               (
    
68.                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "TEXT"))
    
69.                 (set_tile "edit" (cdr (assoc 1 edata)))
    
70.                 (set_tile "error" "普通文字")
    
71.               )
    
72.               (
    
73.                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "MTEXT"))
    
74.                 (set_tile "edit" (cdr (assoc 1 edata)))
    
75.                 (set_tile "error" "段落文字")
    
76.               )
    
77.               (
    
78.                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "ATTRIB"))
    
79.                 (set_tile "edit" (cdr (assoc 1 edata)))
    
80.                 (set_tile "error" "属性文字")
    
81.               )
    
82.               (
    
83.                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "ATTDEF"))
    
84.                 (set_tile "edit" (cdr (assoc 2 edata)))
    
85.                 (set_tile "error" "属性定义")
    
86.               )
    
87.             )
    
88.             (mode_tile "edit" 2)
    
89.             (c_img "tucengcolor" colorname)
    
90.             (action_tile "edit" "(setq new $value)")
    
91.             (set_tile "tucengcolor" (strcat"   "(itoa colorname)))
    
92.             (action_tile "tucengcolor" "(setq colorname(getdata14 colorname))(c_img $key colorname)");;;;图层颜色按钮的动作
    
93.             (action_tile "accept" "(setq result T)(done_dialog 1)")
    
94.             (action_tile "cancel" "(done_dialog 0)")
    
95.             (start_dialog)
    
96.           )
    
97.         )
    
98.       )
    
99.       (unload_dialog id)
    
100.       (if result
     
101.         (progn
     
102.           (if (= (cdr (assoc 0 (entget (car esel)))) "ATTDEF")
     
103.             (setq edata (subst (cons 2 new) (assoc 2 edata) edata))
     
104.             (setq edata (subst (cons 1 new) (assoc 1 edata) edata))
     
105.           )
     
106.           (entmod edata)
     
107.           (if (and (> (length esel) 2)(= (cdr (assoc 0 (entget (car (last esel))))) "INSERT"))
     
108.             (progn
     
109.               (setq name (cdr (assoc 2 (entget (car (last esel))))))
     
110.               (setq ss (ssget "x" '((0 . "insert"))) n 0)
     
111.               (repeat (sslength ss)
     
112.                 (setq esel (ssname ss n) n (1+ n))
     
113.                 (if (= (cdr (assoc 2 (entget esel))) name)
     
114.                   (progn
     
115.                     (entupd esel)
     
116.                       )
     
117.                     )
     
118.               )
     
119.             )
     
120.             (progn
     
121.             (entupd (car esel))
     
122.              )
     
123.           )
     
124.         )
     
125.       )
     
126.     )
     
127.     (T (princ "\n不是文字"))
     
128.   )
     
129.   (setq newwenzi (cdr(assoc 1 edata)))
     
130.   (if (/= oldwenzi newwenzi)
     
131.     (progn
     
132.    (vla-put-color (vlax-ename->vla-object (car esel)) colorname)
     
133.    ;(vla-Regen AcadDocument :vlax-true)
     
134.    (entupd (car esel))
     
135.    )
     
136.     )
     
137.   (newerr)
     
138.   (princ)
     
139. )
     

(defun newerr()<br />   (setq *error* olderr esel nil edata nil d nil new nil do nil ss nil name nil)<br />   (command "undo" "e")<br />   (princ)<br /> )<br /> <br /> (defun c:ue(/ esel edata enme id new do ss name)<br />   (setq olderr *error* *error* newerr )<br />   (if (not colorname )(setq colorname 1)colorname)<br />   (gc)<br />   (setvar "cmdecho" 0)<br />   (command "undo" "be")<br />   (VL-LOAD-COM)<br />   (setq AcadObject(vlax-get-acad-object)<br />         AcadDocument(vla-get-ActiveDocument Acadobject)<br />         mSpace(vla-get-ModelSpace Acaddocument)<br /> )<br /> (defun getdata14(color / ccc);;;定义获取acad标准颜色函数<br />     (setq ccc(acad_colordlg color t))<br />     (if (not ccc)(setq ccc color))<br />     ccc<br />     )<br />   (defun c_img(key color);;;定义初始化颜色图像按钮函数<br />     (if color<br />       (progn<br />         (start_image key)<br />         (fill_image 0 0 (dimx_tile key)(dimy_tile key)color)<br />         (end_image)<br />         )<br />       )<br />     )<br />   (setq esel (nentsel "\n选择文字"))<br />   (setq edata (entget (car esel)))<br />   (setq oldwenzi (cdr(assoc 1 edata)))<br />   (if<br />     (and<br />       (> (length esel) 2)<br />       (= (cdr (assoc 0 (entget (car esel)))) "MTEXT")<br />       (= (cdr (assoc 0 (entget (car (last esel))))) "DIMENSION")<br />     )<br />     (setq enme (car (last esel)) edata (entget enme))<br />   )<br />   (cond<br />     (<br />       (or<br />         (= (cdr (assoc 0 edata)) "TEXT")<br />         (= (cdr (assoc 0 edata)) "MTEXT")<br />         (= (cdr (assoc 0 edata)) "DIMENSION")<br />         (= (cdr (assoc 0 edata)) "ATTRIB")<br />         (= (cdr (assoc 0 edata)) "ATTDEF")<br />       )<br />       (if (> (setq id (load_dialog "ue.dcl")) 0)<br />         (if (new_dialog "edit" id)<br />           (progn<br />              (cond<br />               (<br />                 (= (cdr (assoc 0 edata)) "DIMENSION")<br />                 (set_tile "edit" (vl-string-subst  "" "\\A1;" (cdr (assoc 1 (entget (car esel))))))<br />                 (set_tile "error" "尺寸文字")<br />               )<br />               (<br />                 (and (> (length esel) 2)(= (cdr (assoc 0 (entget (car (last esel))))) "INSERT"))<br />                 (set_tile "edit" (cdr (assoc 1 edata)))<br />                 (set_tile "error" "块中文字")<br />               )<br />               (<br />                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "TEXT"))<br />                 (set_tile "edit" (cdr (assoc 1 edata)))<br />                 (set_tile "error" "普通文字")<br />               )<br />               (<br />                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "MTEXT"))<br />                 (set_tile "edit" (cdr (assoc 1 edata)))<br />                 (set_tile "error" "段落文字")<br />               )<br />               (<br />                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "ATTRIB"))<br />                 (set_tile "edit" (cdr (assoc 1 edata)))<br />                 (set_tile "error" "属性文字")<br />               )<br />               (<br />                 (and (= (length esel) 2)(= (cdr (assoc 0 (entget (car esel)))) "ATTDEF"))<br />                 (set_tile "edit" (cdr (assoc 2 edata)))<br />                 (set_tile "error" "属性定义")<br />               )<br />             )<br />             (mode_tile "edit" 2)<br />             (c_img "tucengcolor" colorname)<br />             (action_tile "edit" "(setq new $value)")<br />             (set_tile "tucengcolor" (strcat"   "(itoa colorname)))<br />             (action_tile "tucengcolor" "(setq colorname(getdata14 colorname))(c_img $key colorname)");;;;图层颜色按钮的动作<br />             (action_tile "accept" "(setq result T)(done_dialog 1)")<br />             (action_tile "cancel" "(done_dialog 0)")<br />             (start_dialog)<br />           )<br />         )<br />       )<br />       (unload_dialog id)<br />       (if result<br />         (progn<br />           (if (= (cdr (assoc 0 (entget (car esel)))) "ATTDEF")<br />             (setq edata (subst (cons 2 new) (assoc 2 edata) edata))<br />             (setq edata (subst (cons 1 new) (assoc 1 edata) edata))<br />           )<br />           (entmod edata)<br />           (if (and (> (length esel) 2)(= (cdr (assoc 0 (entget (car (last esel))))) "INSERT"))<br />             (progn<br />               (setq name (cdr (assoc 2 (entget (car (last esel))))))<br />               (setq ss (ssget "x" '((0 . "insert"))) n 0)<br />               (repeat (sslength ss)<br />                 (setq esel (ssname ss n) n (1+ n))<br />                 (if (= (cdr (assoc 2 (entget esel))) name)<br />                   (progn<br />                     (entupd esel)<br />                       )<br />                     )<br />               )<br />             )<br />             (progn<br />             (entupd (car esel))<br />              )<br />           )<br />         )<br />       )<br />     )<br />     (T (princ "\n不是文字"))<br />   )<br />   (setq newwenzi (cdr(assoc 1 edata)))<br />   (if (/= oldwenzi newwenzi)<br />     (progn<br />    (vla-put-color (vlax-ename->vla-object (car esel)) colorname)<br />    ;(vla-Regen AcadDocument :vlax-true)<br />    (entupd (car esel))<br />    )<br />     )<br />   (newerr)<br />   (princ)<br /> )<br />

1. 
   

复制代码

wdq10105

好程序，美中不足的是速度有点慢

e2002

一直觉得AutoCAD在保留修改过程这一点上很不好,实践中不得不使用各种方法来纪录各种修改过程和某些需要纪录的内容,注释...

怎么就不能给对象们增加一个 Comment 属性呢? 目前只能用 Hyperlink 来暂时替代这个需求.
我希望能在光标Rollover对象时,能自动显示其 Comment 提示文字(如:何时修改的,为何修改的,其表示什么...),就象其他的 Layer,Color属性那样.

puzb2001

好程序，美中不足的是我没用得起来，不知道别的兄弟测试的结果如何？

虾米海

puzb2001 发表于 2012-3-2 15:28
好程序，美中不足的是我没用得起来，不知道别的兄弟测试的结果如何？

具体是放到什么路径下 大侠可以告诉一下吗？

虾米海

楼主 这个怎么用呀  dcl 文件又怎么弄呢？能具体点吗  

429014673

如果每次都没有REGEN就好了。。。。图档大就不好了。。。。块文字好像不变色

puzb2001

试试把LTSCALE调高点看看？是不是速度就快了

puzb2001

yjr111 兄：“下载fas测试一下吧，感觉不慢”。正解，谢谢

mice6672

很有意思的文字编辑，比过去r14下面的ddedit还要强大