Posted to tcl by kevin_walzer at Sat Jan 31 15:56:54 GMT 2009view pretty
namespace eval simplednd { #create the drag icon with empty text and image to initialize; then hide the icon proc makeDragIcon {txt img} { variable dragicon variable dragtext variable dragimage #create the icon 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 proc dragRegister {w target dragcmd dropcmd} { variable dragicon variable dragtext variable dragimage catch {simplednd::makeDragIcon {} {}} puts "$w registered as dragsite with $target as the drop target" #binding for when drag motion begins bind $w <B1-Motion> [list [namespace current]::dragMove %W %X %Y $dragcmd $target] #binding for when drop event occurs bind $w <ButtonRelease-1> [list [namespace current]::dragStop %W %X %Y $target $dropcmd ] } #drag motion with following args: source widget, cursor x position, cursor y position, drag command, target widget proc dragMove {w x y dragcmd target} { variable dragicon variable dragtext variable dragimage #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 #change cursor to drag cursor $w configure -cursor diamond_cross catch {raise $dragicon} #this places the drag icon right above the cursor set x [expr {$x - ([winfo reqwidth $dragicon] / 2) }] set y [expr {$y - [winfo reqheight $dragicon] - 6 }] wm geometry $dragicon +$x+$y update } #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 proc dragStop {w x y target dropcmd} { variable dragicon variable dragtext variable dragimage #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 } } #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 foreach item {do re mi} { .l insert end $item } foreach item {fa so la} { .b insert end $item } pack .l -side left pack .b -side right #register drag sources, drag targets, and callbacks dragRegister .l .b [namespace current]::drag_l [namespace current]::drop_l dragRegister .b .l [namespace current]::drag_b [namespace current]::drop_b } #dragcommand for demo l widget: configures dragicon proc drag_l {} { variable dragicon 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 dragicon variable dragtext variable dragimage .b insert end $dragtext .l delete [.l curselection] } #dragcommand for demo b widget: configures dragicon proc drag_b {} { variable dragicon 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 dragicon variable dragtext variable dragimage .l insert end $dragtext .b delete [.b curselection] } namespace export * } ::simplednd::demo