/[ascend]/trunk/tcltk/TK/templates/ascListSelect.tcl
ViewVC logotype

Contents of /trunk/tcltk/TK/templates/ascListSelect.tcl

Parent Directory Parent Directory | Revision Log Revision Log


Revision 571 - (show annotations) (download) (as text)
Tue May 9 00:14:59 2006 UTC (18 years ago) by johnpye
File MIME type: text/x-tcl
File size: 9306 byte(s)
Renaming 'tcltk98' to 'tcltk', continued...
1 # Program: ascListSelectBox.tcl
2 # Tcl version: 8.0
3 # Tk version: 8.0
4 # XF version: 2.2
5 # Ben Allan may 19 1994 ballan@cs.cmu.edu
6 # $Revision: 1.10 $
7 # $Date: 1998/06/11 14:10:17 $
8 #
9 # requires ascKeepOnTop.tcl if a grabby selection is used
10 #
11
12 global ascListSelectBox
13 set ascListSelectBox(button) 0
14 set ascListSelectBox(itemselected) ""
15 set ascListSelectBox(selectmode) single
16 set ascListSelectBox(toplevelname) ".asclistselect"
17 set ascListSelectBox(grab) 0
18 set ascListSelectBox(btn3name) Help
19 set ascListSelectBox(btn3command) {puts "Help pushed"}
20 set ascListSelectBox(btn3destroy) 0
21 set ascListSelectBox(btn4name) ""
22 set ascListSelectBox(btn4command) ""
23 set ascListSelectBox(btn4destroy) 0
24 set ascListSelectBox(btn5name) ""
25 set ascListSelectBox(btn5command) ""
26 set ascListSelectBox(btn5destroy) 0
27 set ascListSelectBox(font) -*-*
28 set ascListSelectBox(title) ListSelect
29 set ascListSelectBox(headline) "Choices:"
30 #
31 # proc AscListSelectBox {ascListSelectBoxInfo {ascListSelectBoxGeom 250x240}}
32 #---------------------------------------------------------------------------
33 # pretty descriptive name, eh?
34 # Returns number of button pressed, also setting array button to that value.
35 # Item(s) selected will be in ascListSelectBox(itemselected).
36 # The values of
37 # ascListSelectBox(selectmode) (as in listbox widgets)
38 # ascListSelectBox(grab)
39 # ascListSelectBox(toplevelname)
40 # ascListSelectBox(title) (window manager title)
41 # ascListSelectBox(headline) (box heading)
42 # ascListSelectBox(btn3name)
43 # ascListSelectBox(btn3command) should be a procedure name.
44 # ascListSelectBox(btn3destroy)
45 # ascListSelectBox(btn4name)
46 # ascListSelectBox(btn4command) should be a procedure name.
47 # ascListSelectBox(btn4destroy)
48 # ascListSelectBox(btn5name)
49 # ascListSelectBox(btn5command) should be a procedure name.
50 # ascListSelectBox(btn5destroy)
51 # are consulted at build time.
52 # If another box with the same toplevel name
53 # exists, build is aborted and cancel button is returned.
54 # If grab is true, the box will have a grab on it.
55 # grab or no grab, this beast may commandeer the command line.
56 # If btn3/4/5name is "", no btn3/4/5 will be built
57 # If btn3/4/5destroy is 1,
58 # btn3/4/5 will do its command and destroy the window,else
59 # btn3/4/5 will just do its command. In either case, the selection will be
60 # in ascListSelectBox(itemselected) when btn3/4/5command is called.
61 # $btn3/4/5command should not require arguments.
62 # It is a good idea to set the ascListSelectBox array every time
63 # you call this, as others are likely using it also.
64 # Widget configurables:
65 # ascListSelectBox(font) -*-* (duh)
66 #---------------------------------------------------------------------------
67 proc AscListSelectBox {ascListSelectBoxInfo {ascListSelectBoxGeom 250x240}} {
68
69 global ascListSelectBox
70
71 # if no list or conflicting toplevel, return cancel
72 if {$ascListSelectBoxInfo == "" || \
73 [winfo exists $ascListSelectBox(toplevelname)]} {
74 set ascListSelectBox(button) 2
75 set ascListSelectBox(itemselected) ""
76 catch {wm deiconify $ascListSelectBox(toplevelname)}
77 catch {raise $ascListSelectBox(toplevelname)}
78 return 2
79 }
80 set tl $ascListSelectBox(toplevelname)
81 # build widget
82 toplevel $tl
83
84 # Window manager configurations
85 #global tk_version
86 wm positionfrom $tl user
87 wm sizefrom $tl user
88 wm minsize $tl 250 240
89 wm geometry $tl $ascListSelectBoxGeom
90 wm title $tl $ascListSelectBox(title)
91
92 # build widget $tl.buttons_frm
93 frame $tl.buttons_frm \
94 -borderwidth 0
95
96 # build widget $tl.buttons_frm.cancel_button
97 button $tl.buttons_frm.cancel_button \
98 -font $ascListSelectBox(font) \
99 -text Cancel \
100 -width 7 \
101 -command "
102 global ascListSelectBox
103 set ascListSelectBox(itemselected) \"\"
104 set ascListSelectBox(button) 2
105 destroy $tl"
106
107 # build widget $tl.buttons_frm.btn3
108 if {$ascListSelectBox(btn3name)!=""} {
109 button $tl.buttons_frm.btn3 \
110 -borderwidth 2 \
111 -font $ascListSelectBox(font) \
112 -text $ascListSelectBox(btn3name) \
113 -width [string length $ascListSelectBox(btn3name)] \
114 -command "
115 global ascListSelectBox
116 set ascListSelectBox(button) 3
117 ascLSOKCommand $tl
118 $ascListSelectBox(btn3command)"
119 if {$ascListSelectBox(btn3destroy)} {
120 $tl.buttons_frm.btn3 config -command "
121 global ascListSelectBox
122 set ascListSelectBox(button) 3
123 ascLSOKCommand $tl
124 $ascListSelectBox(btn3command)
125 destroy $tl"
126 }
127 }
128
129 # build widget $tl.buttons_frm.btn4
130 if {$ascListSelectBox(btn4name)!=""} {
131 button $tl.buttons_frm.btn4 \
132 -borderwidth 2 \
133 -font $ascListSelectBox(font) \
134 -text $ascListSelectBox(btn4name) \
135 -width [string length $ascListSelectBox(btn4name)] \
136 -command "
137 global ascListSelectBox
138 set ascListSelectBox(button) 4
139 ascLSOKCommand $tl
140 $ascListSelectBox(btn4command)"
141 if {$ascListSelectBox(btn4destroy)} {
142 $tl.buttons_frm.btn4 config -command "
143 global ascListSelectBox
144 set ascListSelectBox(button) 4
145 ascLSOKCommand $tl
146 $ascListSelectBox(btn4command)
147 destroy $tl"
148 }
149 }
150 # build widget $tl.buttons_frm.btn5
151 if {$ascListSelectBox(btn5name)!=""} {
152 button $tl.buttons_frm.btn5 \
153 -borderwidth 2 \
154 -font $ascListSelectBox(font) \
155 -text $ascListSelectBox(btn5name) \
156 -width [string length $ascListSelectBox(btn5name)] \
157 -command "
158 global ascListSelectBox
159 set ascListSelectBox(button) 5
160 ascLSOKCommand $tl
161 $ascListSelectBox(btn5command)"
162 if {$ascListSelectBox(btn5destroy)} {
163 $tl.buttons_frm.btn5 config -command "
164 global ascListSelectBox
165 set ascListSelectBox(button) 5
166 ascLSOKCommand $tl
167 $ascListSelectBox(btn5command)
168 destroy $tl"
169 }
170 }
171 # build widget $tl.buttons_frm.ok_button
172 button $tl.buttons_frm.ok_button \
173 -borderwidth 2 \
174 -text {OK} \
175 -font $ascListSelectBox(font) \
176 -width 3 \
177 -command "
178 global ascListSelectBox
179 ascLSOKCommand $tl
180 set ascListSelectBox(button) 1
181 destroy $tl"
182
183 # pack widget $tl.buttons_frm
184 pack append $tl.buttons_frm \
185 $tl.buttons_frm.ok_button {left frame center expand fill} \
186 $tl.buttons_frm.cancel_button {left frame center expand fill}
187 if {$ascListSelectBox(btn3name)!=""} {
188 pack append $tl.buttons_frm \
189 $tl.buttons_frm.btn3 {left frame center expand fill}
190 }
191 if {$ascListSelectBox(btn4name)!=""} {
192 pack append $tl.buttons_frm \
193 $tl.buttons_frm.btn4 {left frame center expand fill}
194 }
195 if {$ascListSelectBox(btn5name)!=""} {
196 pack append $tl.buttons_frm \
197 $tl.buttons_frm.btn5 {left frame center expand fill}
198 }
199
200 # build widget $tl.lbl_frm
201 frame $tl.lbl_frm
202
203 # build widget $tl.lbl_frm.main_label
204 label $tl.lbl_frm.main_label \
205 -text $ascListSelectBox(headline)
206
207 # pack widget $tl.lbl_frm
208 if {$ascListSelectBox(grab)} {
209 canvas $tl.lbl_frm.bmcanvas -width 33 -height 27
210 $tl.lbl_frm.bmcanvas create bitmap 0 0 \
211 -background yellow \
212 -anchor nw \
213 -bitmap grablock
214 pack append $tl.lbl_frm $tl.lbl_frm.bmcanvas {left frame w}
215 }
216
217 pack append $tl.lbl_frm \
218 $tl.lbl_frm.main_label {top frame center pady 5 fillx}
219
220 # build widget $tl.main_frm
221 frame $tl.main_frm
222
223 # build widget $tl.main_frm.lb_frame
224 frame $tl.main_frm.lb_frame
225
226 # build widget $tl.main_frm.lb_frame.scrollbar2
227 scrollbar $tl.main_frm.lb_frame.scrollbar2 \
228 -command "$tl.main_frm.lb_frame.listbox1 yview"
229
230 # build widget $tl.main_frm.lb_frame.listbox1
231 listbox $tl.main_frm.lb_frame.listbox1 \
232 -exportselection 0 \
233 -font $ascListSelectBox(font) \
234 -selectmode $ascListSelectBox(selectmode) \
235 -width 20 \
236 -height 5 \
237 -relief {sunken} \
238 -yscrollcommand "$tl.main_frm.lb_frame.scrollbar2 set"
239
240 # pack widget $tl.main_frm.lb_frame
241 pack append $tl.main_frm.lb_frame \
242 $tl.main_frm.lb_frame.scrollbar2 {right frame center filly} \
243 $tl.main_frm.lb_frame.listbox1 {top frame center expand fill}
244
245 # pack widget $tl.main_frm
246 pack append $tl.main_frm \
247 $tl.main_frm.lb_frame {top frame center expand fill}
248
249 # pack widget $tl
250 pack append $tl \
251 $tl.lbl_frm {top frame center pady 5 fillx} \
252 $tl.main_frm {top frame center expand fill} \
253 $tl.buttons_frm {top frame center fill}
254
255 proc DestroyWindow$tl {} "
256 destroy $tl
257 update"
258
259 # Stuff the information given.
260 if {$ascListSelectBoxInfo != ""} {
261 foreach item $ascListSelectBoxInfo {
262 $tl.main_frm.lb_frame.listbox1 insert end $item
263 }
264 }
265
266 update idletask
267 if {$ascListSelectBox(grab)} {
268 bind $tl <Visibility> {ascKeepOnTop %W}
269 grab $tl
270 }
271 # wait for the box to be destroyed
272 tkwait window $tl
273 return $ascListSelectBox(button)
274 }
275
276 proc ascLSOKCommand {tl} {
277 global ascListSelectBox
278 set ascListSelectBox(itemselected) \
279 [ascGetListSelection $tl.main_frm.lb_frame.listbox1]
280 }
281 #ifndef
282 if {[info proc ascGetListSelection]!="ascGetListSelection"} {
283 #
284 # returns the selection from a listbox widget as a list.
285 proc ascGetListSelection {w} {
286 set indices [$w curselection]
287 set a ""
288 foreach i $indices {
289 lappend a [$w get $i]
290 }
291 return $a
292 }
293 }
294
295 # eof

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22