Well, below i paste the code of simplednd by Kevin Walzer.
First, you must save this as "simplednd.tcl".
##simplednd: implements simple mechanism for drag-and-drop within Tk applications. (c) 2009 WordTech Communications LLC. License: standard Tcl license,
http://www.tcl.tk/software/tcltk/license.html.
package provide simplednd 1.1
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
variable targetdirection
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
variable targetdirection
#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
[namespace current]::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)
proc 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]
#change the icon if over the drop target
if {($x > $targetx) && ($x < $targetwidth) && ($y > $targety) && ($y < $targetheight)} {
$w configure -cursor based_arrow_down
} 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
proc dragStop {w x y target dropcmd} {
variable dragicon
variable dragtext
variable dragimage
variable targetdirection
#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 *
}
Now, save this as "pkgIndex.tcl"
# Tcl package index file, version 1.1
# This file is generated by the "pkg_mkIndex" command
# and sourced either when an application starts up or
# by a "package unknown" script. It invokes the
# "package ifneeded" command to set up package-related
# information so that packages will be loaded automatically
# in response to "package require" commands. When this
# script is sourced, the variable $dir must contain the
# full path name of this file's directory.
package ifneeded simplednd 1.1 [list source [file join $dir simplednd.tcl]]
Finally, the help :
The simpleDND Package
The simpleDND package implements a lightweight mechanism for drag-and-drop operations within a single Tcl/Tk application. When used, it provides a visual icon and cursor change to indicate a dragged object, and can execute any Tcl command upon a
successful drop operation. The package is designed to be easy-to-use, with just a few commands required to add drag-and-drop. Any widget can be registered as a drag source or drop target.
simpleDND is called via package require simpleDND. It is implemented with the following command:
* proc dragRegister {w target dragcmd dropcmd}: w is the source widget where the drag is initiated, target is the target widget where the drop is completed, dragcmd is the Tcl command that is executed on the start of the drag operation, and dropcmd is
the Tcl command that is executed when the drop operation is completed. simplednd::dragRegister must be called for each widget that is set up as a drag source. For instance, if you have a listbox .l and a listbox .b that are both drag sources, the command must be called for each widget. Also, if listbox .l and listbox .b
have multiple drop targets, then the command must be called for each drop target.
The dragcmd should be used to configure the drag icon. The variables ::simplednd::dragtext and ::simplednd::dragimg are used for this purpose. At a minimum, you must define a single command setting default values for the dragtext and dragimg variables,
or you can provide a different command for each drag operation. simpleDND does not provide default values for the text or image in the drag icon; without at least one dragcmd, you will be dragging around an empty label as the drag icon.
The dropcmd is called on a successful drop, i.e. when the button is released over the drop target registered with the drag source. If the button is released over a widget that is not registered as the drop target, the cursor changes to a standard arrow
and the drag icon disappears.
A demonstration of simpleDND is included with the package. Call simplednd::demo after loading the package. You can also inspect the demo source code for ideas on how to implement simpleDND in your own applications.
Ok, that's all.
I hope this help you.
Alejandro
--- SoupGate-Win32 v1.05
* Origin: fsxNet Usenet Gateway (21:1/5)