# snitdnd: implements simple mechanism for drag-and-drop within Tk
# applications. based on [simplednd]
# (c) 2009 WordTech Communications LLC (simplednd). License: standard Tcl
# Kevin Walzer http://www.codebykevin.com/opensource/xplat_oss.html
# (c) 2012 Dr. Detlef Groth, University of Potsdam (snitdnd). License: standard Tcl
# for license see https://www.tcl-lang.org/software/tcltk/license.html
# starkit-file: https://bitbucket.org/mittelmark/tcl-code/downloads/snitdnd.kit
##############################################################################
# based on simplednd from the Tcl-Wiki by WordTexCommunications LLC
# snitdnd advantages:
# * no collision if several registered drag events have to share the same variable
# * improved demo
# * -trackcmd option can be supplied to monitor the actual object on the target site.
# this is demonstraded by hilighting the dragtargets in the demo
# just do a:
# % package require snitdnd
# % snitdnddemo::demo
# to see the demo example
# you can drag items from the left to the middle listbox
# you can drag items from the middle to the left listbox
# you can drag items within the right listbox
package require snit
snit::type snitdnd {
option -trackcmd {}
option -dragcmd {}
option -dropcmd {}
option -target {}
option -source {}
option -dragtextvar ""
typevariable dragicon
typevariable dragtext
typevariable dragimage
variable targetdirection
constructor {args} {
$self configurelist $args
$self dragRegister $options(-source) $options(-target) \
$options(-dragcmd) $options(-dropcmd) $options(-trackcmd)
trace add variable $options(-dragtextvar) write [mymethod setDragText]
}
method setDragText {varname key op} {
upvar $varname var
set dragtext $var
}
method makeDragIcon {txt img} {
#create the icon
if {![info exists dragicon]} {
set dragicon [toplevel .dnd]
set dragtext $txt
set dragimage $img
wm overrideredirect $dragicon true
label $dragicon.view -image $dragimage -text $dragtext -compound left
pack $dragicon.view
#now hide the icon
wm withdraw $dragicon
}
}
# register widget to respond to drag events: widget to register, its
# target widget, callback to associate with this drag event, text for the
# drag label, and image for the drag label
method dragRegister {w target dragcmd dropcmd trackcmd} {
puts "cmd: $options(-trackcmd)"
$self makeDragIcon {} {}
puts "$w registered as dragsite with $target as the drop target"
#binding for when drag motion begins
bind $w <B1-Motion> [mymethod dragMove %W %X %Y $dragcmd $target]
#binding for when drop event occurs
bind $w <ButtonRelease-1> [mymethod dragStop %W %X %Y $target $dropcmd]
}
# drag motion with following args: source widget, cursor x position,
# cursor y position, drag command, target widget
method dragMove {w x y dragcmd target} {
#the dragcmd properly configures the drag icon
eval $dragcmd
#configure drag icon with customized text and image
$dragicon.view configure -text $dragtext -image $dragimage
#dragicon appears
wm deiconify $dragicon
catch {raise $dragicon}
#this places the drag icon below the cursor
set x [expr {$x - ([winfo reqwidth $dragicon] / 2) }]
set y [expr {$y - [winfo reqheight $dragicon] + 25 }]
wm geometry $dragicon +$x+$y
$self trackCursor $w $x $y $target
}
# track the cursor, change if it is over the drop target; args are source
# widget (w), x pos (x), y pos (y), target widget (target)
method trackCursor {w x y target} {
#get the coordinates of the drop target
set targetx [winfo rootx $target]
set targety [winfo rooty $target]
set targetwidth [expr [winfo width $target] + $targetx]
set targetheight [expr [winfo height $target] + $targety]
if {$options(-trackcmd) ne ""} {
$options(-trackcmd) $w $x $y $target
}
#change the icon if over the drop target
if {($x > $targetx) && ($x < $targetwidth) && ($y > $targety) && ($y < $targetheight)} {
$w configure -cursor based_arrow_up
} else {
$w configure -cursor dot
}
}
# dragstop/drop event with following args: source widget, cursor x
# position, cursor y position, target widget, dropcommand: if over drop
# target, execute dropcommand; otherwise simply return
method dragStop {w x y target dropcmd} {
#hide dragicon on drop event
wm withdraw $dragicon
#change cursor back to arrow
$w configure -cursor arrow
#execute callback or simply return
if {[winfo containing $x $y] != $target} {
puts "target $w not reached"
} else {
focus -force $target
eval $dropcmd
}
}
}
namespace eval snitdnddemo {
#demo package
proc demo {} {
variable dragicon
variable dragtext
variable dragimage
#create image for demo
image create photo dnd_demo -data {R0lGODlhEAAQALMAAAAAAMbGxv//////////////////////////////////\
/////////////////////yH5BAEAAAEALAAAAAAQABAAAAQwMMhJ6wQ4YyuB\
+OBmeeDnAWNpZhWpmu0bxrKAUu57X7VNy7tOLxjIqYiapIjDbDYjADs=}
listbox .l -selectmode single -activestyle none
listbox .b -selectmode single -activestyle none
listbox .s -selectmode single -activestyle none
foreach item {do re mi} {
.l insert end $item
.s insert end $item
}
foreach item {fa so la} {
.b insert end $item
.s insert end $item
}
pack .l -side left
pack .b -side left
pack .s -side left
#register drag sources, drag targets, and callbacks
snitdnd snd1 -source .l -target .b -dragcmd [namespace current]::drag_l \
-dropcmd [namespace current]::drop_l -trackcmd [namespace current]::track \
-dragtextvar [namespace current]::dragtext
snitdnd snd2 -source .b -target .l -dragcmd [namespace current]::drag_b \
-dropcmd [namespace current]::drop_b -trackcmd [namespace current]::track \
-dragtextvar [namespace current]::dragtext
snitdnd snd3 -source .s -target .s -dragcmd [namespace current]::drag_s \
-dropcmd [namespace current]::drop_s -trackcmd [namespace current]::track \
-dragtextvar [namespace current]::dragtext
}
proc drag_l {} {
variable dragtext
variable dragimage
set item [lindex [.l get [.l curselection]]]
set dragtext $item
set dragimage dnd_demo
}
#dropcommand for demo l widget: callback to execute on drop
proc drop_l {} {
variable dragtext
variable dragimage
variable lastIdx
.b insert $lastIdx(.b) $dragtext
.l delete [.l curselection]
}
#dragcommand for demo b widget: configures dragicon
proc drag_b {} {
variable dragtext
variable dragimage
set item [lindex [.b get [.b curselection]]]
set dragtext $item
set dragimage dnd_demo
}
#dropcommand for demo b widget: callback to execute on drop
proc drop_b {} {
variable dragtext
variable dragimage
variable lastIdx
.l insert $lastIdx(.l) $dragtext
.b delete [.b curselection]
}
proc drag_s {} {
variable dragtext
variable dragimage
set item [lindex [.s get [.s curselection]]]
set dragtext $item
set dragimage navup22 ;#dnd_demo
}
proc drop_s {} {
variable dragtext
variable dragimage
variable lastIdx
.s insert $lastIdx(.s) $dragtext
.s delete [.s curselection]
}
proc track {w x y target} {
variable lastIdx
set idx [$target nearest [expr $y - [winfo rooty $target]]]
puts "y=[expr [winfo rooty $target] + $y]"
#puts [.tf.tbl rowcget $idx -text]
if {[info exists lastIdx($target)]} {
$target itemconfigure $lastIdx($target) -foreground black
$target itemconfigure $lastIdx($target) -background white
}
$target itemconfigure $idx -foreground blue
$target itemconfigure $idx -background "light blue"
set lastIdx($target) $idx
}
}
package provide snitdnd 0.1