模拟院长的超级刷子功能，实用但界面不够美观。。。。

77077

绝对原创，啥也不说了，直接上源码，求高手们拓展改进~~~

2. (defun MAKE-DCL-SSS        (lst FILENAME / F1 I)
   
3. (if        (setq F1 (open FILENAME "w"))
   
4.         (progn
   
5.           (write-line "MY_SSS: dialog{ label = "我的小刷子 ";" F1)
   
6.           (write-line ":boxed_column{   label="点选要刷相同的属性:";" F1)
   
7.           (setq I 0)
   
8.           (foreach N lst
   
9.                   (progn
   
10.                     (write-line
    
11.                             (strcat        ":toggle{ label=""
    
12.                                     (strcat (car N) "     " (vl-princ-to-string (cdr N)))
    
13.                                     "";   key = "KEY"
    
14.                                     (itoa I)
    
15.                                     ""; width=35;  action="(do-addlst "
    
16.                                     (itoa I)
    
17.                                     ")";value="0";  }"
    
18.                             )
    
19.                            F1
    
20.                     )
    
21.                   (setq I (1+ I))
    
22.                   )
    
23.           );end foreach
    
24.           (write-line "}" F1)
    
25.           (write-line "ok_only;" F1)
    
26.           (write-line "}" F1)
    
27.           (close F1)
    
28.           t
    
29.         )
    
30. )
    
31. )
    
32. (defun do-addlst (INT)
    
33.     (if        (= $VALUE "1") ;_表示被选中
    
34.         (setq LST1 (cons INT LST1))
    
35.         (setq LST1 (vl-remove INT LST1))
    
36.     )
    
37. )
    
38. ;组码批量修改
    
39. (defun pgzm (ss lst / e el i)
    
40.   (setq i -1)
    
41.   (while (setq e (ssname ss (setq i (1+ i))))
    
42.     (setq el (entget e))
    
43.     (mapcar '(lambda (x / l)
    
44.                (if (setq l (assoc (car x) el))
    
45.                  (setq el (subst x l el))
    
46.                  (setq el (append el (list x)))
    
47.                )
    
48.              )
    
49.             lst
    
50.     )
    
51.     (entmod el)
    
52.   )
    
53. )
    
54. ;;;==============================
    
55. (defun c:matdxf(/ DXFLST1 EntType DXFLST DXFLST2 x y y2 dcl_name ID ID2 LST1 LST2 n lst3 SS I ENTI TMP)
    
56.         (princ "\n 我的小刷子，同类刷")
    
57.         (setq DXFLST1 (entget(car(entsel "\n点取源对象: ")))
    
58.                     EntType (cdr (assoc 0 DXFLST1))
    
59.              )
    
60.         (if (not (assoc 62 DXFLST1))
    
61.                 (setq DXFLST1 (append DXFLST1 (list '(62 . 256))))
    
62.         )
    
63.         (setq DXFLST
    
64.         (cond
    
65. ((= EntType "ARC")   ;分支
    
66. '(
    
67.                  (10 . "圆心坐标")
    
68.                  (40 . "圆弧半径")
    
69.                  (50 . "起点角度")
    
70.                  (51 . "终点角度")
    
71.                  (8 . "所在图层")
    
72.                  (62 . "实体颜色")
    
73.                  ))
    
74. ((= EntType "ATTDEF")   ;分支
    
75. '(
    
76.      (1 . "默认值")
    
77.                  (2 . "标记字符串")
    
78.                  (3 . "提示字符串" )
    
79.                  (7 . "文字样式")
    
80.                  (10 . "文字基点")
    
81.                  (40 . "文字高度")
    
82.                  (8 . "所在图层")
    
83.                  (62 . "实体颜色")
    
84.                  ))
    
85. ((= EntType "CIRCLE")   ;分支
    
86. '(
    
87.                  (10 . "圆心坐标")
    
88.                  (40 . "圆形半径")
    
89.                  (8 . "所在图层")
    
90.                  (62 . "实体颜色")
    
91.                  ))
    
92. ((= EntType "POINT")   ;分支
    
93. '(
    
94.                  (10 . "点的位置")
    
95.                  (8 . "所在图层")
    
96.                  (62 . "实体颜色")
    
97.                  ))
    
98. ((= EntType "LINE")   ;分支
    
99. '(
    
100.                  (10 . "起点坐标")
     
101.                  (11 . "终点坐标")
     
102.                  (8 . "所在图层")
     
103.                  (62 . "实体颜色")
     
104.                  ))
     
105. ((= EntType "TEXT")   ;分支
     
106. '(
     
107.                  (1 . "文字内容")
     
108.                  (7 . "文字样式")
     
109.                  (10 . "插入位置")
     
110.                  (40 . "文字高度")
     
111.                  (41 . "宽度系数")
     
112.                  (50 . "旋转角度")
     
113.                  (51 . "倾斜角度")
     
114.                  (8 . "所在图层")
     
115.                  (62 . "实体颜色")
     
116.                  ))
     
117. ((= EntType "INSERT")   ;分支
     
118. '(
     
119.      (2 . "图块名称")
     
120.                  (10 . "图块位置")
     
121.                  (41 . "X 轴比例")
     
122.                  (42 . "Y 轴比例")
     
123.                  (43 . "Z 轴比例")
     
124.                  (50 . "旋转角度")
     
125.                  (8 . "所在图层")
     
126.                  (62 . "实体颜色")
     
127.                  ))
     
128. ((= EntType "LWPOLYLINE")   ;分支
     
129. '(
     
130.                  (43 . "固定宽度")
     
131.                  (38 . "复线标高")
     
132.                  (39 . "复线厚度")
     
133.                  (70 . "是否闭合")
     
134.                  (8 . "所在图层")
     
135.                  (62 . "实体颜色")
     
136.                  ))
     
137. ((= EntType "MTEXT")   ;分支
     
138. '(
     
139.                  (10 . "插入位置")
     
140.                  (1 . "文字内容")
     
141.                  (7 . "文字样式")
     
142.                  (40 . "文字高度")
     
143.                  (41 . "参照宽度")
     
144.                  (50 . "旋转角度")
     
145.                  (71 . "附着点")
     
146.                  (8 . "所在图层")
     
147.                  (62 . "实体颜色")
     
148.                  ))
     
149.                  (t (alert "不支持的类型"));分支        
     
150.          );END cond
     
151. );setq
     
152. (if DXFLST
     
153. (progn
     
154. (foreach x DXFLST   ;转化成人能轻易识别的DXF组码表
     
155.         (if (setq y (assoc (car x) DXFLST1))
     
156.           (setq y2 (LIST (cdr x) (cdr y))
     
157.                 DXFLST2 (cons y2 DXFLST2)
     
158.           )
     
159.         )
     
160. )
     
161.   (setq DXFLST (mapcar '(lambda (X) (cons (cdr X) (car X))) DXFLST))
     
162.   (setq dcl_name (strcat (getenv "temp") "\\AcadMat" ".dcl"));;创建临时对话框文件
     
163.   (MAKE-DCL-SSS DXFLST2 dcl_name)              ;;;开始写对话框
     
164.   (>= (setq ID (load_dialog dcl_name)) 0)      ;;;载入对话框文件
     
165.   (new_dialog "MY_SSS" ID)                     ;;;初始化对话框，在屏幕上显示
     
166.   (setq ID2 (start_dialog))                    ;;;启动对话框
     
167. (if        (and (= ID2 1) (> (length LST1) 0))
     
168.                 (progn                    
     
169.                     (foreach N LST1 (setq LST2 (cons (nth N DXFLST2) LST2)))                  ;取出要修改的组码代号
     
170.                     (setq LST2 (mapcar '(lambda(X) (cdr(assoc X DXFLST))) (mapcar 'car LST2)));从原图元中取出对应的值
     
171.                     (foreach x LST2                                                           ;还原成电脑识别的DXF组码表
     
172.                             (setq lst3 (cons (assoc x DXFLST1) lst3))
     
173.                      )
     
174.                      (princ "\n选择要刷同的同类实体：")
     
175.                     (while (setq SS (ssget (list (cons 0 EntType))))                          ;过滤选择要处理的对象
     
176.                             (pgzm ss lst3)
     
177.                             (princ "\n  >>>>继续选择要刷同的同类实体<右键退出>：")        
     
178.                     )
     
179.                 );progn
     
180. );if
     
181. (unload_dialog ID);;;卸载对话框文件  
     
182. (vl-file-delete dcl_name)
     
183. );progn
     
184. );if
     
185. (princ)
     
186. )

(defun MAKE-DCL-SSS        (lst FILENAME / F1 I)<br /> (if        (setq F1 (open FILENAME "w"))<br />         (progn<br />           (write-line "MY_SSS: dialog{ label = "我的小刷子 ";" F1)<br />           (write-line ":boxed_column{   label="点选要刷相同的属性:";" F1)<br />           (setq I 0)<br />           (foreach N lst<br />                   (progn<br />                     (write-line<br />                             (strcat        ":toggle{ label=""<br />                                     (strcat (car N) "     " (vl-princ-to-string (cdr N)))<br />                                     "";   key = "KEY"<br />                                     (itoa I)<br />                                     ""; width=35;  action="(do-addlst "<br />                                     (itoa I)<br />                                     ")";value="0";  }"<br />                             )<br />                            F1<br />                     )<br />                   (setq I (1+ I))<br />                   )<br />           );end foreach<br />           (write-line "}" F1)<br />           (write-line "ok_only;" F1)<br />           (write-line "}" F1)<br />           (close F1)<br />           t<br />         )<br /> )<br /> )<br /> (defun do-addlst (INT)<br />     (if        (= $VALUE "1") ;_表示被选中<br />         (setq LST1 (cons INT LST1))<br />         (setq LST1 (vl-remove INT LST1))<br />     )<br /> )<br /> ;组码批量修改<br /> (defun pgzm (ss lst / e el i)<br />   (setq i -1)<br />   (while (setq e (ssname ss (setq i (1+ i))))<br />     (setq el (entget e))<br />     (mapcar '(lambda (x / l)<br />                (if (setq l (assoc (car x) el))<br />                  (setq el (subst x l el))<br />                  (setq el (append el (list x)))<br />                )<br />              )<br />             lst<br />     )<br />     (entmod el)<br />   )<br /> )<br /> ;;;==============================<br /> (defun c:matdxf(/ DXFLST1 EntType DXFLST DXFLST2 x y y2 dcl_name ID ID2 LST1 LST2 n lst3 SS I ENTI TMP)<br />         (princ "\n 我的小刷子，同类刷")<br />         (setq DXFLST1 (entget(car(entsel "\n点取源对象: ")))<br />                     EntType (cdr (assoc 0 DXFLST1))<br />              )<br />         (if (not (assoc 62 DXFLST1))<br />                 (setq DXFLST1 (append DXFLST1 (list '(62 . 256))))<br />         )<br />         (setq DXFLST<br />         (cond<br /> ((= EntType "ARC")   ;分支<br /> '(<br />                  (10 . "圆心坐标")<br />                  (40 . "圆弧半径")<br />                  (50 . "起点角度")<br />                  (51 . "终点角度")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "ATTDEF")   ;分支<br /> '(<br />      (1 . "默认值")<br />                  (2 . "标记字符串")<br />                  (3 . "提示字符串" )<br />                  (7 . "文字样式")<br />                  (10 . "文字基点")<br />                  (40 . "文字高度")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "CIRCLE")   ;分支<br /> '(<br />                  (10 . "圆心坐标")<br />                  (40 . "圆形半径")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "POINT")   ;分支<br /> '(<br />                  (10 . "点的位置")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "LINE")   ;分支<br /> '(<br />                  (10 . "起点坐标")<br />                  (11 . "终点坐标")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "TEXT")   ;分支<br /> '(<br />                  (1 . "文字内容")<br />                  (7 . "文字样式")<br />                  (10 . "插入位置")<br />                  (40 . "文字高度")<br />                  (41 . "宽度系数")<br />                  (50 . "旋转角度")<br />                  (51 . "倾斜角度")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "INSERT")   ;分支<br /> '(<br />      (2 . "图块名称")<br />                  (10 . "图块位置")<br />                  (41 . "X 轴比例")<br />                  (42 . "Y 轴比例")<br />                  (43 . "Z 轴比例")<br />                  (50 . "旋转角度")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "LWPOLYLINE")   ;分支<br /> '(<br />                  (43 . "固定宽度")<br />                  (38 . "复线标高")<br />                  (39 . "复线厚度")<br />                  (70 . "是否闭合")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br /> ((= EntType "MTEXT")   ;分支<br /> '(<br />                  (10 . "插入位置")<br />                  (1 . "文字内容")<br />                  (7 . "文字样式")<br />                  (40 . "文字高度")<br />                  (41 . "参照宽度")<br />                  (50 . "旋转角度")<br />                  (71 . "附着点")<br />                  (8 . "所在图层")<br />                  (62 . "实体颜色")<br />                  ))<br />                  (t (alert "不支持的类型"));分支        <br />          );END cond<br /> );setq<br /> (if DXFLST<br /> (progn<br /> (foreach x DXFLST   ;转化成人能轻易识别的DXF组码表<br />         (if (setq y (assoc (car x) DXFLST1))<br />           (setq y2 (LIST (cdr x) (cdr y))<br />                 DXFLST2 (cons y2 DXFLST2)<br />           )<br />         )<br /> )<br />   (setq DXFLST (mapcar '(lambda (X) (cons (cdr X) (car X))) DXFLST))<br />   (setq dcl_name (strcat (getenv "temp") "\\AcadMat" ".dcl"));;创建临时对话框文件<br />   (MAKE-DCL-SSS DXFLST2 dcl_name)              ;;;开始写对话框<br />   (>= (setq ID (load_dialog dcl_name)) 0)      ;;;载入对话框文件<br />   (new_dialog "MY_SSS" ID)                     ;;;初始化对话框，在屏幕上显示<br />   (setq ID2 (start_dialog))                    ;;;启动对话框<br /> (if        (and (= ID2 1) (> (length LST1) 0))<br />                 (progn                    <br />                     (foreach N LST1 (setq LST2 (cons (nth N DXFLST2) LST2)))                  ;取出要修改的组码代号<br />                     (setq LST2 (mapcar '(lambda(X) (cdr(assoc X DXFLST))) (mapcar 'car LST2)));从原图元中取出对应的值<br />                     (foreach x LST2                                                           ;还原成电脑识别的DXF组码表<br />                             (setq lst3 (cons (assoc x DXFLST1) lst3))<br />                      )<br />                      (princ "\n选择要刷同的同类实体：")<br />                     (while (setq SS (ssget (list (cons 0 EntType))))                          ;过滤选择要处理的对象<br />                             (pgzm ss lst3)<br />                             (princ "\n  >>>>继续选择要刷同的同类实体<右键退出>：")        <br />                     )<br />                 );progn<br /> );if<br /> (unload_dialog ID);;;卸载对话框文件  <br /> (vl-file-delete dcl_name)<br /> );progn<br /> );if<br /> (princ)<br /> )

lucas_3333

给楼主参考下吧

1. ;;Command / Functions --
   
2. 
   
3. ;;c:AxProps -- prompts you to to select an entity.
   
4. ;;c:NAxProps -- prompts you to to select a nested entity.
   
5. ;;AxProps, syntax: (AxProps x), where x is any valid object, ename or handle.
   
6. 
   
7. 
   
8. (defun c:Propsx ( / mia getkey key lst )
   
9. 
   
10.     (cond
    
11.    
    
12.         (   (and
    
13.                 (setq mia (null AxProps))
    
14.                 (null (findfile "axprops.fas"))
    
15.             )
    
16.             (princ "Cannot find axprops.fas, aborting.")
    
17.         )   
    
18.         
    
19.         (   (and
    
20.                 mia
    
21.                 (eq 'failed (load "axprops.fas"))
    
22.             )
    
23.             (princ "Cannot load axprops.fas, aborting.")
    
24.         )
    
25.         
    
26.         (   (defun GetKey ( / result )
    
27.                 (while
    
28.                     (null
    
29.                         (eq 2
    
30.                             (car
    
31.                                 (setq result (grread))
    
32.                             )
    
33.                         )
    
34.                     )
    
35.                 )
    
36.                 (cadr result)
    
37.             )
    
38. 
    
39.             (setq lst
    
40.                 (mapcar 'ascii
    
41.                    '("p" "P" "n" "N" "\r" " ")
    
42.                 )
    
43.             )
    
44.             
    
45.             (if mia (princ "\n\n"))
    
46. 
    
47.             (princ
    
48.                 (strcat
    
49.                     "Press [p] or [enter] to select a "
    
50.                     "primary entity, [n] for a nested one: "
    
51.                 )   
    
52.             )
    
53. 
    
54.             (while
    
55.                 (null
    
56.                     (member
    
57.                         (setq key (GetKey))
    
58.                         lst
    
59.                     )
    
60.                 )   
    
61.             )
    
62. 
    
63.             (setq ename
    
64.                 (car
    
65.                     (if (member key (mapcar 'ascii '("n" "N")))
    
66.                         (nentsel)
    
67.                         (entsel)
    
68.                     )
    
69.                 )
    
70.             )
    
71.             
    
72.             (vl-load-com)
    
73. 
    
74.             (AxProps ename)
    
75.         )
    
76.     )   
    
77. 
    
78.     (princ)
    
79.    
    
80. )

;;Command / Functions --<br /> <br /> ;;c:AxProps -- prompts you to to select an entity.<br /> ;;c:NAxProps -- prompts you to to select a nested entity.<br /> ;;AxProps, syntax: (AxProps x), where x is any valid object, ename or handle.<br /> <br /> <br /> (defun c:Propsx ( / mia getkey key lst )<br /> <br />     (cond<br />     <br />         (   (and<br />                 (setq mia (null AxProps))<br />                 (null (findfile "axprops.fas"))<br />             )<br />             (princ "Cannot find axprops.fas, aborting.")<br />         )    <br />         <br />         (   (and<br />                 mia<br />                 (eq 'failed (load "axprops.fas"))<br />             )<br />             (princ "Cannot load axprops.fas, aborting.")<br />         )<br />         <br />         (   (defun GetKey ( / result )<br />                 (while <br />                     (null <br />                         (eq 2 <br />                             (car <br />                                 (setq result (grread))<br />                             )<br />                         )<br />                     )<br />                 )<br />                 (cadr result)<br />             )<br /> <br />             (setq lst <br />                 (mapcar 'ascii<br />                    '("p" "P" "n" "N" "\r" " ")<br />                 )<br />             )<br />             <br />             (if mia (princ "\n\n"))<br /> <br />             (princ <br />                 (strcat<br />                     "Press [p] or [enter] to select a "<br />                     "primary entity, [n] for a nested one: "<br />                 )    <br />             )<br /> <br />             (while <br />                 (null <br />                     (member <br />                         (setq key (GetKey))<br />                         lst<br />                     )<br />                 )    <br />             )<br /> <br />             (setq ename<br />                 (car<br />                     (if (member key (mapcar 'ascii '("n" "N")))<br />                         (nentsel)<br />                         (entsel)<br />                     )<br />                 )<br />             )<br />             <br />             (vl-load-com)<br /> <br />             (AxProps ename)<br />         )<br />     )    <br /> <br />     (princ)<br />     <br /> )

tianyi1230

上一个对话框整合版的!

meja

命令: MATDXF
我的小刷子，同类刷
点取源对象: 错误 : 参数太多

77077

贴上院长的超级刷子
http://bbs.mjtd.com/forum.php?mod=viewthread&tid=109750

yoyoho

感谢 77077 分享程序!!!

dbqtju

谢谢分享程序!!!

伪书虫86

啥也不说了，谢谢楼主

spp_wall

怎么点了出了对话框后没反应？

hao3ren

确实点击了没反应

77077

多谢楼上提醒，已经更新了~
原因是论坛插件修改了代码
本来是

2. (defun do-addlst (INT)
   
3.     (if        (= $VALUE "1") ;_表示被选中
   
4.         (setq LST1 (cons INT LST1))
   
5.         (setq LST1 (vl-remove INT LST1))
   
6.     )
   
7. )

(defun do-addlst (INT)<br />     (if        (= $VALUE "1") ;_表示被选中<br />         (setq LST1 (cons INT LST1))<br />         (setq LST1 (vl-remove INT LST1))<br />     )<br /> )

贴出来后变成了

2. (defun do-addlst (INT)
   
3.   (if (= $$$$VALUE "1") ;_表示被选中
   
4.     (setq LST1 (cons INT LST1))
   
5.     (setq LST1 (vl-remove INT LST1))
   
6.   )
   
7. )

(defun do-addlst (INT)<br />   (if (= $$$$VALUE "1") ;_表示被选中<br />     (setq LST1 (cons INT LST1))<br />     (setq LST1 (vl-remove INT LST1))<br />   )<br /> )

77077

lucas_3333 发表于 2015-6-5 12:54
给楼主参考下吧

让高手见笑了，我怎么不会用你这个程序呀？求演示~~~