Version 0 of Widget Drag and Drop Notebook

Updated 2010-07-26 18:30:54 by CJB

CJB: Based upon Widget Drag and Drop BWidget Notebook.

Allows dragging and dropping widgets into ttk::notebook pages or tabs.


package require Tk 8.5

#Create main widgets.
set m [frame .m]
set p [panedwindow $m.p]
$p add [set f [frame $p.f]         ]
$p add [set n [ttk::notebook $p.n] ]

pack $m -fill both -expand 1
pack $p -fill both -expand 1

#DnD Source binds
bind DropSource <ButtonPress>   [list ChildButtonPress   %W]
bind DropSource <ButtonRelease> [list ChildButtonRelease %W %X %Y %x %y]
bind DropSource <Motion>        [list ChildMotion        %W %X %Y %x %y]

#DnD Target binds
bind DropTarget <<ChildDrop>> [list ChildDrop %d %W %x %y]
bindtags $f [linsert [bindtags $f] 1 DropTarget]
bindtags $n [linsert [bindtags $n] 1 DropTarget]

#Tab creation
foreach tab [list First Second Third] {
        set w [frame $n.[string tolower $tab]]
    $n add $w -text $tab
    bindtags $w [linsert [bindtags $w] 1 DropTarget]
}

#DnD Source Creation
foreach text [list "Child A" "Child B" "Child C" "Child D" "Child E"] {
    set w $p.[string map {{ } _} [string tolower $text]]
    label $w -text $text -background lightgray
    bindtags $w [linsert [bindtags $w] 1 DropSource ]
    pack $w -in $f -fill x
}

#Sets "active" widget and colors it green.
proc ChildButtonPress {w} {
    variable active $w
    $w configure -background green
}

#Generates a <<ChildDrop>> event on the underlying widget
#Needs to generate another event first for the NoteBook to trigger correctly.
#In this case we use an <Enter> event. (Probably not needed in concurrency with ChildMotion)
#The child will be colored red if an error occurs.
proc ChildButtonRelease {W X Y x y } {
    variable active
    variable n
    if {[info exists active]} {
        set z [winfo containing $X $Y]
        $W configure -background red
        catch {
            set x [expr {$X - [winfo rootx $z]}]
            set y [expr {$Y - [winfo rooty $z]}]
            #Needs a primary event to allow correct trigger on virtual event.
            event generate $z <Enter>       -x $x -y $y
            event generate $z <<ChildDrop>> -x $x -y $y -data $W
            $W configure -background lightgray
        } m o
        if {[dict get $o -code] != 0} {puts stderr $m}
        unset -nocomplain active
    }
}

#Passes <Motion> events to underlying widgets while dragging children.
proc ChildMotion {W X Y x y} {
    set w [winfo containing $X $Y]
    if {$w ne $W} {
        set x [expr {$X - [winfo rootx $w]}]
        set y [expr {$Y - [winfo rooty $w]}]
        event generate $w <Motion> -x $x -y $y
    }
}


#Called on widgets that a DropSource has been released upon.
proc ChildDrop {slave master x y} {
    variable n
    puts "ChildDrop: $slave  ->  $master"
    if {$n eq $master} {
                set idx [$n index @$x,$y]
                if {$idx == ""} {
                        return
                } else {
                        set master [lindex [$n tabs] $idx]
                }
        }
    pack  $slave -in $master
        raise $slave
}

#Utility for debugging binds/traces
proc print {args} {puts $args}

bind all <KeyPress-?> {console show}