MG 19 Feb 2018 - This code impliments simple drag-and-drop reordering for the Listbox widget. It works with listboxes with -selectmode set to either single or multiple (not browse or extending, which already have 'dragging' behaviour for altering selection).
MG 21/2/18 Added -command to ListboxDnD::enable
To use, create a listbox, then do
package require ListboxDnD
ListboxDnD::enable $listbox ?-command $command?If a -command is specified, the command is run when the list order is successfully changed via dragging. May contain %W which is replaced with the widget path prior to execution.
The code:
namespace eval ::ListboxDnD {
variable data;
variable state;
}
bind ListboxDnD <1> [list ::ListboxDnD::start %W %x %y]
bind ListboxDnD <Escape> "[list ::ListboxDnD::cancel %W %x %y];break"
bind ListboxDnD <B1-Motion> [list ::ListboxDnD::drag %W %x %y]
bind ListboxDnD <ButtonRelease-1> [list ::ListboxDnD::stop %W %x %y]
# Enable listbox $lb to be re-ordered with drag and drop
# Possible args:
# -command $cmd - run $cmd after the list has been rearranged, replacing %W with the window path
proc ::ListboxDnD::enable {lb {args}} {
variable data;
if { ![winfo exists $lb] || [winfo class $lb] ne "Listbox" } {
return 0;
}
set bt [bindtags $lb]
if { [set bti [lsearch -exact $bt "Listbox"]] < 0 } {
return 0;
}
foreach {x y} $args {
if { $x eq "-command" } {
if { $y eq "" } {
unset -nocomplain data($lb,-command)
} else {
set data($lb,-command) $y
}
} else {
error "Invalid option $x: Must be -command"
}
}
if { "ListboxDnD" in $bt } {
return 1;# already done
}
bindtags $lb [linsert $bt $bti+1 "ListboxDnD"]
return 1;
};#enable
# Called on B1 press to set up for a drag
proc ::ListboxDnD::start {lb x y} {
variable state;
if { [$lb cget -state] ne "normal" || [$lb cget -selectmode] ni [list "single" "multiple"] } {
return;
}
set _listvar [$lb cget -listvariable]
if { $_listvar eq "" } {
return;
}
upvar #0 $_listvar listvar
if { ![info exists listvar] || [llength $listvar] < 2 } {
return;
}
set state($lb,list) $listvar
set state($lb,startindex) [$lb index @$x,$y]
set state($lb,currindex) $state($lb,startindex)
set state($lb,startsel) [$lb curselection]
return;
};# start
# Called on B1 motion, as an item is being dragged
proc ::ListboxDnD::drag {lb x y} {
variable state;
set _listvar [$lb cget -listvariable]
if { $_listvar eq "" || ![info exists state($lb,list)] } {
return;
}
upvar #0 $_listvar listvar
set newpos [$lb nearest $y]
set oldpos $state($lb,currindex)
if { $newpos == $oldpos } {
return;
}
set sel [$lb curselection]
if { $oldpos in $sel && $newpos ni $sel } {
$lb selection clear $oldpos
$lb selection set $newpos
} elseif { $oldpos ni $sel && $newpos in $sel } {
$lb selection clear $newpos
$lb selection set $oldpos
}
set newlist $listvar
set oldval [lindex $newlist $oldpos]
set newval [lindex $newlist $newpos]
set newlist [lreplace $newlist $oldpos $oldpos $newval]
set newlist [lreplace $newlist $newpos $newpos $oldval]
set listvar $newlist
set state($lb,currindex) $newpos
return;
};# drag
# Called when Escape is pressed; cancel a drag
proc ::ListboxDnD::cancel {lb x y} {
variable state;
if { ![info exists state($lb,list)] } {
return;
}
set _listvar [$lb cget -listvariable]
if { $_listvar eq "" } {
return;
}
upvar #0 $_listvar listvar
set listvar $state($lb,list)
$lb selection clear 0 end
foreach x $state($lb,startsel) {
$lb selection set $x
}
array unset state $lb,*
return;
};# cancel
# Called on B1 release; finalise a drag
proc ::ListboxDnD::stop {lb x y} {
variable state;
variable data;
if { ![info exists state($lb,startindex)] } {
return; # drag was cancelled
}
set start $state($lb,startindex)
set curr $state($lb,currindex)
array unset state $lb,*
if { $start == $curr } {
return;# Wasn't dragged anyway
}
if { [info exists data($lb,-command)] } {
catch {uplevel #0 [string map [list %W $lb] $data($lb,-command)]}
}
return;
};# stop
package provide ListboxDnD 1.0
Example:
set list [list foo bar baz boing sprocket] pack [listbox .lb -listvariable list -selectmode single] ListboxDnD::enable .lb