Completed this megawidget. Here's the script:
# test-listPicker.tcl
#!/ bin/sh
#\
exec tclsh "%0" "$@"
package require Gnocl
#---------------
# megawidget to contain Ok/Cancel buttons
#---------------
proc gnocl::listPicker { args } {
set titles {"Item" data}
set types {string string}
set ls(from) [gnocl::list \
-titles $titles \
-types $types ]
set ls(to) [gnocl::list \
-titles $titles \
-types $types ]
# are any names data?
set i [lsearch $titles data ]
$ls(from) columnConfigure $i -visible 0
$ls(to) columnConfigure $i -visible 0
#~~~~~~~~~~~~~~~
# move items between two lists
#~~~~~~~~~~~~~~~
proc ::moveItem { from to i} {
set active [$from getSelection]
if {$active == ""} {return}
set rows [$from getNumChildren]
set a [$from get $active 0]
set b [$from get $active 1]
$from erase $active
set rows [$from getNumChildren]
# set new active row
if { $active < $rows } {
$from setSelection $active
} elseif {$rows == 1} {
$from setSelection 0
} else {
if { $rows != 0 } { $from setSelection [incr rows -1] }
}
$to add "\{\{$a\} \{$b\}\}"
}
#~~~~~~~~~~~~~~~
# return a list of selected items
#~~~~~~~~~~~~~~~
proc ::getList { w } {
set r 0
while {$r < [$w getNumChildren] } {
lappend str [ list [$w get $r 0] [$w get $r 1] ]
incr r
}
return $str
}
# selection buttons
set but(from) [gnocl::button \
-icon %#GoForward \
-onClicked "::moveItem $ls(from) $ls(to) $i" ]
set but(to) [gnocl::button \
-icon %#GoBack \
-onClicked "::moveItem $ls(to) $ls(from) $i"]
set bx(1) [gnocl::fixed ]
$bx(1) add $but(from) \
-x 0 -y 50 \
-width 70 -height 35
$bx(1) add $but(to) \
-x 0 -y 100 \
-width 70 -height 35
set bx(2) [gnocl::box]
$bx(2) add $ls(from) \
-fill {1 1} \
-expand 1
$bx(2) add $bx(1) -fill {0 1}
$bx(2) add $ls(to) \
-fill {1 1} \
-expand 1
$bx(2) configure -data $ls(to)
# allocate which elements get which settings
foreach {a b} $args {
switch -- $a {
-items {
# create from list from supplied items
foreach row $b {
$ls(from) add "\{$row\}"
}
}
-headersVisible {
# create from list from supplied items
$ls(from) configure $a $b
$ls(to) configure $a $b
}
default {
# nothing in here yet!
}
}
}
# overload the box to add commands
rename $bx(2) _$bx(2)
#~~~~~~~~~~~~~~~
# overload box widget to create new commands
#~~~~~~~~~~~~~~~
proc $bx(2) {cmd args} {
set self [lindex [::info level 0] 0]
switch -- $cmd {
get {
return [::getList [_$self cget -data] ]
}
default {uplevel 1 _$self $cmd $args}
}
}
return $bx(2)
}
set items {
{New "New File"}
{Open "Open File"}
{Save "Save File"}
{Help "Help Me"}
}
set box [gnocl::box -orientation vertical]
set lp [gnocl::listPicker -items $items -headersVisible 0]
set bt [gnocl::button -text "Get Selected Options" -onClicked { puts [$lp get]}]
$box add $lp -fill {1 1} -expand 1
$box add $bt -fill {0 0} -expand 0 -align right
gnocl::window -child $box -setSize 0.25
Comments