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