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

Contents of /trunk/tcltk/TK/templates/amlscroll.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: 2751 byte(s)
Renaming 'tcltk98' to 'tcltk', continued...
1 #
2 # Labelled multilist scrollbox creator.
3 # By Benjamin Andrew Allan
4 # May 3, 1998
5 # Copyright 1998 Carnegie Mellon University
6 #
7 # ascLabeledMultiList parent label width
8 # Adds a listbox to the parent frame with a label at the top of the
9 # list box. If this is the first added listbox, the parent also gets
10 # a scrollbar for controlling the box. Width specifies the initial
11 # width of the added list widget.
12 # On subsequent calls with the same parent, the listbox is added to
13 # the right of the already defined listboxes.
14 # Calls with distinct parents are handled independently.
15 # Within one parent all listboxes are scrolled identically.
16 #
17 # Returns the name of the added listbox.
18
19 global ascMLVect
20 catch {unset ascMLVect}
21
22 proc ascMLset {lbox args} {
23 global ascMLVect
24 set parent $ascMLVect($lbox)
25 foreach lb $ascMLVect($parent.frame) {
26 eval $lb.box $args
27 }
28 }
29
30 proc ascMLscroll {scrollbar lbox args} {
31 global ascMLVect
32 set parent $ascMLVect($lbox)
33 eval $scrollbar set $args
34 ascMLset $lbox yview moveto [lindex $args 0]
35 }
36
37 proc ascLabeledMultiList {parent label width} {
38 global ascMLVect
39 if {![info exists ascMLVect($parent)]} {
40 set ascMLVect($parent) 0
41 set ascMLVect($parent.sy) $parent
42 scrollbar $parent.sy -orient v -command [list ascMLset $parent.sy yview]
43 pack $parent.sy -fill y -side right
44 }
45 set n $parent.list$ascMLVect($parent)
46 incr ascMLVect($parent)
47 lappend ascMLVect($parent.frame) $n
48
49 frame $n
50
51 # build widget $n.box
52 listbox $n.box \
53 -exportsel no \
54 -width $width \
55 -selectmode browse \
56 -yscrollcommand "ascMLscroll $parent.sy $n.box" \
57 -height 3
58
59 set ascMLVect($n.box) $parent
60
61 foreach i {1 2 3 4 5 6 7 8} {
62 $n.box insert end $i
63 }
64
65 bind $n.box <ButtonPress-1> {
66 ascMLset %W select clear 0 end
67 ascMLset %W select set [%W nearest %y]
68 }
69
70 bind $n.box <B1-Motion> {
71 ascMLset %W select clear 0 end
72 ascMLset %W select set [%W nearest %y]
73 ascMLset %W see [%W nearest %y]
74 }
75
76 bind $n.box <ButtonRelease-1> {
77 ascMLset %W select clear 0 end
78 ascMLset %W select set [%W nearest %y]
79 }
80
81 # build widget $n.label
82 label $n.label \
83 -borderwidth {1} \
84 -text $label
85
86 pack configure $n.label \
87 -fill x
88 pack configure $n.box \
89 -expand 1 \
90 -fill both
91 pack configure $n \
92 -expand 1 \
93 -side left \
94 -fill both
95
96 return $n.box
97 }
98 set test 0
99 if {$test} {
100 catch {destroy .t}
101 catch {destroy .u}
102 toplevel .t
103 ascLabeledMultiList .t c1
104 ascLabeledMultiList .t c2
105 ascLabeledMultiList .t c3
106 ascLabeledMultiList .t c4
107 ascLabeledMultiList .t c5
108 toplevel .u
109 ascLabeledMultiList .u c1
110 ascLabeledMultiList .u c2
111 ascLabeledMultiList .u c3
112 ascLabeledMultiList .u c4
113 ascLabeledMultiList .u c5
114 }

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