源码DCL通用函数再次修改版！

AbnerXk

初版界面：

此函数原作者为：llsheng_73 在此感谢。

新版界面：

1. (defun c:tt()
   
2.   (setq lst '((" " ("xxx1 个人工具" "xxx2 个人工具" "xxx3 个人工具" "xxx4 个人工具" "xxx5 个人工具" "xxx6 个人工具"))))
   
3.   (Dcl-ButtonM "xx工具" lst nil "帮助字符串")
   
4. )
   
5. ;; titl:标题; buttons:按钮列表; flag:nil先行后列T先列后行 helpstr: nil "帮助字符串"
   
6. (defun Dcl-ButtonM (titl buttons flag helpstr / a b bq1 bq2 bqb c DivlstTh lsxth wh cmds csz ctl d dcl dclfile dclhandle divlst divth fileid i is_cancel kbnil key lst1 lsx n sk-cmdunknown sk-rctcmds str str_lst tem tems true tx v vr x y zbcd zhcfb)
   
7. (or (and helpstr (/= helpstr "")) (setq helpstr "!!!死心吧,没写呢!!!"))
   
8. (defun strsplist (str / i)
   
9.   (if  (setq i (vl-string-search " " str))
   
10.   (list (substr str 1 i)
    
11.     (vl-string-trim " " (substr str (+ 2 i)))
    
12.   )
    
13.   )
    
14. )
    
15. (defun makedcl (str_lst / fileID dclHandle);临时生成对话框文件，用完需删除
    
16.   (setq dclfile (vl-filename-mktemp nil nil ".dcl")
    
17.     fileID(open dclfile "w")
    
18.   )
    
19.   (cond ((= (type str_lst) 'str) (write-line str_lst fileID))
    
20.     ((= (type str_lst) 'list)
    
21.    (foreach n str_lst (write-line n fileID))
    
22.     )
    
23.   )
    
24.   (close fileID)
    
25.   (setq dclHandle (load_dialog dclfile))
    
26. )
    
27.   (setq vr 0)
    
28. 
    
29. (setq  b (if flag
    
30.     ":column{ label = \""
    
31.     ":row{children_alignment = top ;\n
    
32.   children_fixed_height = true ;\n label = \""
    
33.     )
    
34.   c (if flag
    
35.     ":row{children_alignment = top ;\n
    
36.   children_fixed_height = true ;\nlabel = \""
    
37.     ":column{label = \""
    
38.     )
    
39.   d '("ESC")
    
40.   a (strcat (vl-string-translate
    
41.       "$~"
    
42.       "AB"
    
43.       (vl-filename-base (vl-filename-mktemp))
    
44.       )
    
45.       ":dialog{label=\""
    
46.       titl
    
47.       "\";\n"
    
48.       b
    
49.       "\";\n"
    
50.     )
    
51. )
    
52.   (setq kbnil '())
    
53. (foreach x buttons
    
54.   (setq lsx (last x))
    
55.   (setq a (strcat a c (car x) "\";\n"))
    
56.   (setq tem 0)
    
57.   (setq csz 500)
    
58.   (setq lsxth (length lsx))
    
59.   (if (or (> lsxth 70) (= lsxth 70))
    
60.     (setq wh 6)
    
61.     (setq wh 5)
    
62.   )
    
63.   (setq divlst (Div-List lsx wh))
    
64.   (setq zbcd (length (nth (- (length divlst) 1) divlst)))
    
65.   (setq DivlstTh (length divlst))
    
66.   (if (and (< zbcd wh) (/= zbcd wh))
    
67.     (progn
    
68.         (setq bq1 (- wh zbcd))
    
69.       (repeat bq1
    
70.             (setq tems (rtos tem))
    
71.         (setq bqb (append (nth (- DivlstTh 1) divlst) (list (strcat "~" tems " "))))
    
72.         (setq divlst (append (vl-remove (nth (- DivlstTh 1) divlst) divlst) (list bqb)))
    
73.         (setq divth DivlstTh)
    
74.         (setq tem (1+ tem))
    
75.       )
    
76.      )
    
77.   )
    
78.   (if (or (and (< divth 10) (/= divth 10) (/= divth nil)) (<= DivlstTh 10))
    
79.     (progn
    
80.         (setq bq2 (- 10 DivlstTh))
    
81.       (repeat bq2
    
82.         (repeat wh (setq kbnil (append kbnil (list (strcat "~" (rtos csz) " ")))) (setq csz (1+ csz)))
    
83.       )
    
84.     )
    
85.   )
    
86.     (setq zhcfb (Div-List kbnil wh))
    
87.   (setq divlst (append divlst zhcfb))
    
88.   (foreach v divlst
    
89.     (setq a (strcat a ":row{\n"))
    
90.   (foreach y v
    
91.     (setq  b (strsplist y)
    
92.       a (if b
    
93.       (strcat a
    
94.           ":button {key =\""
    
95.           (car b)
    
96.           "\";label=\""
    
97.           (last b)
    
98.           "\";"
    
99.     (if (= (substr (car b) 1 1) "~")
    
100.     "is_enabled = false ;" "\n")
     
101.   "width = 15 ;"
     
102.   "height = 2.5 ;"
     
103.     "}\n"
     
104.       )
     
105.       (strcat a "spacer_0;\n")
     
106.       )
     
107.       d (if (/= (car b) nil)
     
108.       (cons (car b) d)
     
109.       d
     
110.       )
     
111.   )
     
112.   )
     
113.           ":button {key =\"" (car b) "\";label=\""
     
114.   (setq a (strcat a "}\n"))
     
115.   )
     
116.   (setq a (strcat a "}\n"))
     
117. 
     
118. );End foreach
     
119. 
     
120. (setq  d  (cdr (REVERSE d))
     
121.   a  (strcat a
     
122.        (if flag
     
123.        "} spacer_1;:row"
     
124.        "} spacer_1;:row"
     
125.        )
     
126.        "{alignment = centered ;fixed_width = true ;
     
127.         :button{fixed_width = true ;width = 4 ;height = 2 ;key = \"help\";label = \" 帮助 \";}\n"
     
128.        ":button{fixed_width = true ;width = 4 ;height = 2 ;key=\"cancel\";label=\" 取消 \";
     
129.        is_cancel = true;is_default = true;}}}"
     
130.      )
     
131.   dcl(makedcl a)
     
132.   lst1 '()
     
133.   i  1
     
134. )
     
135. (foreach key d
     
136.   (setq tx (strcat "(action_tile \""
     
137.        key
     
138.        "\"\"(done_dialog "
     
139.        (itoa i)
     
140.        ")\")"
     
141.      )
     
142.     lst1 (cons tx lst1)
     
143.     i  (1+ i)
     
144.   )
     
145. )
     
146. (new_dialog (substr a 1 8) dcl)
     
147. (action_tile "cancel" "(done_dialog 0)")
     
148. (action_tile "help" "(alert helpstr)")
     
149. (eval (read (strcat "(progn" (apply 'strcat lst1) ")")))
     
150. (setq ctl (start_dialog))
     
151. (unload_dialog dcl)
     
152. (vl-file-delete dclfile)
     
153. (if (/= ctl 0)
     
154.   (progn
     
155.   (setq cmds(nth (- ctl 1) d))
     
156.   ;;检查命令是否~开头,有就去掉,如果运行中没有更改该命令button的enable值,这句可以不要
     
157.   (if (= (substr cmds 1 1) "~") (setq cmds (substr cmds 2 (1- (strlen cmds)))))
     
158.   ;;
     
159. ;  ;设置未知命令反应器
     
160. ;  (if (= sk-rctCmds nil)
     
161. ;(setq sk-rctCmds (vlr-command-reactor nil '((:vlr-unknownCommand . sk-cmdunknown))))
     
162. ;(vlr-add sk-rctCmds)
     
163. ;)
     
164.   ;新的命令判断方式,代码更短
     
165.     (cond
     
166.         ((boundp (read (strcat "c:" cmds)))
     
167.           (princ "\n")
     
168.           (eval (read (strcat "(c:" cmds ")")))
     
169.         )
     
170.         ((boundp (read cmds))
     
171.           (princ "\n")
     
172.           (eval (read (strcat "(" cmds ")")))
     
173.         )
     
174.         (t (princ "\n")(vl-load-com)(vl-cmdf cmds))
     
175.     )
     
176.   )
     
177. )
     
178. )
     
179. 
     
180. ;;;拆分表
     
181. (defun Div-List (lst num / ptn1 ptn2)
     
182. 
     
183.   (while (> (length lst) num)
     
184. 
     
185.     (repeat num
     
186. 
     
187.       (setq ptn1 (cons (car lst) ptn1)
     
188. 
     
189.       lst   (cdr lst)
     
190. 
     
191.       )
     
192. 
     
193.     )
     
194. 
     
195.     (setq ptn2 (cons (reverse ptn1) ptn2)
     
196. 
     
197.     ptn1 '()
     
198. 
     
199.     )
     
200. 
     
201.   )
     
202. 
     
203.   (if (>= (length lst) 1)
     
204. 
     
205.     (setq ptn2 (cons lst ptn2))
     
206. 
     
207.   )
     
208. 
     
209.   (reverse ptn2)
     
210. 
     
211. )
     
212. 
     
213. 
     

(defun c:tt()<br />   (setq lst '((" " ("xxx1 个人<a href="http://bbs.mjtd.com/forum-6-1.html" target="_blank" class="relatedlink">工具</a>" "xxx2 个人工具" "xxx3 个人工具" "xxx4 个人工具" "xxx5 个人工具" "xxx6 个人工具"))))<br />   (Dcl-ButtonM "xx工具" lst nil "帮助字符串")<br /> )<br /> ;; titl:标题; buttons:按钮列表; flag:nil先行后列T先列后行 helpstr: nil "帮助字符串"<br /> (defun Dcl-ButtonM (titl buttons flag helpstr / a b bq1 bq2 bqb c DivlstTh lsxth wh cmds csz ctl d dcl dclfile dclhandle divlst divth fileid i is_cancel kbnil key lst1 lsx n sk-cmdunknown sk-rctcmds str str_lst tem tems true tx v vr x y zbcd zhcfb)<br /> (or (and helpstr (/= helpstr "")) (setq helpstr "!!!死心吧,没写呢!!!"))<br /> (defun strsplist (str / i)<br />   (if  (setq i (vl-string-search " " str))<br />   (list (substr str 1 i)<br />     (vl-string-trim " " (substr str (+ 2 i)))<br />   )<br />   )<br /> )<br /> (defun makedcl (str_lst / fileID dclHandle);临时生成对话框文件，用完需删除<br />   (setq dclfile (vl-filename-mktemp nil nil ".dcl")<br />     fileID(open dclfile "w")<br />   )<br />   (cond ((= (type str_lst) 'str) (write-line str_lst fileID))<br />     ((= (type str_lst) 'list)<br />    (foreach n str_lst (write-line n fileID))<br />     )<br />   )<br />   (close fileID)<br />   (setq dclHandle (load_dialog dclfile))<br /> )<br />   (setq vr 0)<br /> <br /> (setq  b (if flag<br />     ":column{ label = \""<br />     ":row{children_alignment = top ;\n<br />   children_fixed_height = true ;\n label = \""<br />     )<br />   c (if flag<br />     ":row{children_alignment = top ;\n<br />   children_fixed_height = true ;\nlabel = \""<br />     ":column{label = \""<br />     )<br />   d '("ESC")<br />   a (strcat (vl-string-translate<br />       "$~"<br />       "AB"<br />       (vl-filename-base (vl-filename-mktemp))<br />       )<br />       ":dialog{label=\""<br />       titl<br />       "\";\n"<br />       b<br />       "\";\n"<br />     )<br /> )<br />   (setq kbnil '())<br /> (foreach x buttons<br />   (setq lsx (last x))<br />   (setq a (strcat a c (car x) "\";\n"))<br />   (setq tem 0)<br />   (setq csz 500)<br />   (setq lsxth (length lsx))<br />   (if (or (> lsxth 70) (= lsxth 70))<br />     (setq wh 6)<br />     (setq wh 5)<br />   )<br />   (setq divlst (Div-List lsx wh))<br />   (setq zbcd (length (nth (- (length divlst) 1) divlst)))<br />   (setq DivlstTh (length divlst))<br />   (if (and (< zbcd wh) (/= zbcd wh))<br />     (progn <br />         (setq bq1 (- wh zbcd))<br />       (repeat bq1<br />             (setq tems (rtos tem))<br />         (setq bqb (append (nth (- DivlstTh 1) divlst) (list (strcat "~" tems " "))))<br />         (setq divlst (append (vl-remove (nth (- DivlstTh 1) divlst) divlst) (list bqb)))<br />         (setq divth DivlstTh)<br />         (setq tem (1+ tem))<br />       )<br />      )<br />   )<br />   (if (or (and (< divth 10) (/= divth 10) (/= divth nil)) (<= DivlstTh 10))<br />     (progn<br />         (setq bq2 (- 10 DivlstTh))<br />       (repeat bq2<br />         (repeat wh (setq kbnil (append kbnil (list (strcat "~" (rtos csz) " ")))) (setq csz (1+ csz))) <br />       )<br />     )<br />   )<br />     (setq zhcfb (Div-List kbnil wh))<br />   (setq divlst (append divlst zhcfb))<br />   (foreach v divlst<br />     (setq a (strcat a ":row{\n"))<br />   (foreach y v<br />     (setq  b (strsplist y)<br />       a (if b<br />       (strcat a<br />           ":button {key =\""<br />           (car b)<br />           "\";label=\""<br />           (last b)<br />           "\";"<br />     (if (= (substr (car b) 1 1) "~")<br />     "is_enabled = false ;" "\n")<br />   "width = 15 ;"<br />   "height = 2.5 ;"<br />     "}\n"<br />       )<br />       (strcat a "spacer_0;\n")<br />       )<br />       d (if (/= (car b) nil)<br />       (cons (car b) d)<br />       d<br />       )<br />   )<br />   )<br />           ":button {key =\"" (car b) "\";label=\""<br />   (setq a (strcat a "}\n"))<br />   )<br />   (setq a (strcat a "}\n"))<br /> <br /> );End foreach<br /> <br /> (setq  d  (cdr (REVERSE d))<br />   a  (strcat a<br />        (if flag<br />        "} spacer_1;:row"<br />        "} spacer_1;:row"<br />        )<br />        "{alignment = centered ;fixed_width = true ;<br />         :button{fixed_width = true ;width = 4 ;height = 2 ;key = \"help\";label = \" 帮助 \";}\n"<br />        ":button{fixed_width = true ;width = 4 ;height = 2 ;key=\"cancel\";label=\" 取消 \";<br />        is_cancel = true;is_default = true;}}}"<br />      )<br />   dcl(makedcl a)<br />   lst1 '()<br />   i  1<br /> )<br /> (foreach key d<br />   (setq tx (strcat "(action_tile \""<br />        key<br />        "\"\"(done_dialog "<br />        (itoa i)<br />        ")\")"<br />      )<br />     lst1 (cons tx lst1)<br />     i  (1+ i)<br />   )<br /> )<br /> (new_dialog (substr a 1 8) dcl)<br /> (action_tile "cancel" "(done_dialog 0)")<br /> (action_tile "help" "(alert helpstr)")<br /> (eval (read (strcat "(progn" (apply 'strcat lst1) ")")))<br /> (setq ctl (start_dialog))<br /> (unload_dialog dcl)<br /> (vl-file-delete dclfile)<br /> (if (/= ctl 0)<br />   (progn<br />   (setq cmds(nth (- ctl 1) d))<br />   ;;检查命令是否~开头,有就去掉,如果运行中没有更改该命令button的enable值,这句可以不要<br />   (if (= (substr cmds 1 1) "~") (setq cmds (substr cmds 2 (1- (strlen cmds)))))<br />   ;;<br /> ;  ;设置未知命令反应器<br /> ;  (if (= sk-rctCmds nil)<br /> ;(setq sk-rctCmds (vlr-command-reactor nil '((:vlr-unknownCommand . sk-cmdunknown))))<br /> ;(vlr-add sk-rctCmds)<br /> ;)<br />   ;新的命令判断方式,代码更短<br />     (cond <br />         ((boundp (read (strcat "c:" cmds)))<br />           (princ "\n")<br />           (eval (read (strcat "(c:" cmds ")")))<br />         )<br />         ((boundp (read cmds))<br />           (princ "\n")<br />           (eval (read (strcat "(" cmds ")")))<br />         )<br />         (t (princ "\n")(vl-load-com)(vl-cmdf cmds))<br />     )<br />   )<br /> )<br /> )<br /> <br /> ;;;拆分表<br /> (defun Div-List (lst num / ptn1 ptn2)<br /> <br />   (while (> (length lst) num)<br /> <br />     (repeat num<br /> <br />       (setq ptn1 (cons (car lst) ptn1)<br /> <br />       lst   (cdr lst)<br /> <br />       )<br /> <br />     )<br /> <br />     (setq ptn2 (cons (reverse ptn1) ptn2)<br /> <br />     ptn1 '()<br /> <br />     )<br /> <br />   )<br /> <br />   (if (>= (length lst) 1)<br /> <br />     (setq ptn2 (cons lst ptn2))<br /> <br />   )<br /> <br />   (reverse ptn2)<br /> <br /> )<br /> <br /> <br />

此次修改只考虑了一个"column"，因为我只会用到一个，如果有其他需求，请自行理清其中逻辑关系再修改；

自定义按钮将按行排列，数量在70个以下一行按钮数量为5个，超出则一行按钮为6个，如果按钮够多，可再增加判断；

集思广益，如有更好的想法，可一起讨论并继续完善。

取之于明，还之于明，函数下载：

1、2、3、三枪

不错  感谢分享

yumocad

谢谢楼主分享，学习中

烟盒迷唇

面板不错，值得借鉴

spp_wall

谢谢LZ 共享  一直用老迈的！！！！

机械工程师

谢谢分享。

tianyi1230

这是那个ODCL面板，还是DCL面板？好像ODCl面板！

AbnerXk

tianyi1230 发表于 2014-7-22 11:36
这是那个ODCL面板，还是DCL面板？好像ODCl面板！

这是DCL面板。

恕放之生命

好东西，谢谢分享。

ps122hb

谢谢分享，看一下

hhh454

一直用老迈的对话框，这个也挺好

伪书虫86

谢谢楼主的无私奉献
(setq lst '((" " ("xxx1 个人工具" "xxx2 个人工具" "xxx3 个人工具" "xxx4 个人工具" "xxx5 个人工具" "xxx6 个人工具"))))
请教下，xxx1是要替换成对应LSP的快捷命令吗？