Widget Drag and Drop Notebook

CJB: Based upon Widget Drag and Drop BWidget Notebook.

Allows dragging and dropping widgets into ttk::notebook pages or tabs. Does not require BWidget.


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
#The child will be colored red if an error occurs.
proc ChildButtonRelease {W X Y x y } {
    variable active
    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]}]
            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 && $w ne ""} {
        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} {
    puts "ChildDrop: $slave  ->  $master"
    if {[winfo class $master] eq "TNotebook"} {
                set idx [$master index @$x,$y]
                if {$idx == ""} {
                        return
                } else {
                        set master [lindex [$master tabs] $idx]
                }
        }
    pack  $slave -in $master
        raise $slave
}

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

bind all <KeyPress-question> {console show}