namespace eval buttonbar {}
proc buttonbar::create {w frame} {
variable buttonbar
set ns [namespace current]
frame $w
frame $w.middle -relief raised -bd 1
button $w.left -text < -bd 1 -command [list ${ns}::scrollleft $w] -highlightthickness 0 -width 2 -padx 0 -state disabled
button $w.right -text > -bd 1 -command [list ${ns}::scrollright $w] -highlightthickness 0 -width 2 -padx 0 -state disabled
button $w.close -text X -bd 1 -command [list ${ns}::closecurrent $w] -highlightthickness 0 -width 3 -padx 0
canvas $w.middle.c -height [winfo reqheight $w.right] -xscrollincrement 1 -highlightthickness 0
frame $w.middle.c.f
grid $w.left $w.right $w.middle $w.close -sticky nesw -padx 0 -pady 0
# grid $w.left $w.middle $w.right $w.close -sticky nesw -padx 0 -pady 0 ; # Use this to put the right scroll button on the right
grid columnconfigure $w {0 1 3} -minsize 15 -weight 0
grid columnconfigure $w 2 -weight 2
# grid columnconfigure $w 1 -weight 2 ; # Use this to put the right scroll button on the right
pack $w.middle.c -fill both
$w.middle.c create window 0 0 -anchor nw -window $w.middle.c.f
bind $w.middle.c.f <Configure> "$w.middle.c configure -scrollregion \[$w.middle.c bbox all\]"
bind tab <Button-1> "[namespace current]::showframe $w %W; bind tab <Motion> \"[namespace current]::tabdrag $w %W\""
bind tab <ButtonRelease-1> "[namespace current]::tearoff $w %W %X %Y; bind tab <Motion> {}; after cancel \"[namespace current]::tabdrag $w %W\""
bind $w.middle.c <Configure> "[namespace current]::setscrollstate $w"
set buttonbar($w) $frame
return $w
}
proc buttonbar::add {w name} {
variable buttonbar
eval frame $buttonbar($w).$name
button $w.middle.c.f.$name -text $name -highlightthickness 0 -padx 3m -relief groove
pack $w.middle.c.f.$name -side left -pady 0 -padx 0 -fill y
bindtags $w.middle.c.f.$name tab
showframe $w $name
after idle [namespace current]::setscrollstate $w
return $buttonbar($w).$name
}
proc buttonbar::name {w tab name} {
if {![winfo exists $w.middle.c.f.$tab]} return
$w.middle.c.f.$tab configure -text $name
}
proc buttonbar::scrollright {w} {
scrollsetleft $w [winfo containing [expr [winfo rootx $w.middle.c] + [winfo width $w.middle.c] - 1] [winfo rooty $w.middle.c]]
$w.right configure -foreground black -activeforeground black
}
proc buttonbar::scrollleft {w} {
scrollsetright $w [winfo containing [winfo rootx $w.middle.c] [winfo rooty $w.middle.c]]
$w.left configure -foreground black -activeforeground black
}
proc buttonbar::scrollsetleft {w tab} {
set tab [string map "$w.middle.c.f {}" $tab]
if {![winfo exists $w.middle.c.f$tab]} return
$w.middle.c xview scroll [expr [winfo rootx $w.middle.c.f$tab] - [winfo rootx $w.middle.c]] units
}
proc buttonbar::scrollleft {w} {
scrollsetright $w [winfo containing [winfo rootx $w.middle.c] [winfo rooty $w.middle.c]]
$w.left configure -foreground black -activeforeground black
}
proc buttonbar::scrollsetleft {w tab} {
set tab [string map "$w.middle.c.f {}" $tab]
if {![winfo exists $w.middle.c.f$tab]} return
$w.middle.c xview scroll [expr [winfo rootx $w.middle.c.f$tab] - [winfo rootx $w.middle.c]] units
}
proc buttonbar::scrollsetright {w tab} {
set tab [string map "$w.middle.c.f {}" $tab]
if {![winfo exists $w.middle.c.f$tab]} return
$w.middle.c xview scroll [expr -1 * (([winfo rootx $w.middle.c] + [winfo width $w.middle.c]) - ([winfo rootx $w.middle.c.f$tab] + [winfo width $w.middle.c.f$tab]))] units
}
proc buttonbar::closecurrent {w} {
variable buttonbar
foreach x [winfo children $w.middle.c.f] {
if {[$x cget -relief] == "raised"} {
destroy $x $buttonbar($w).[string map "$w.middle.c.f. {}" $x]
return
}
}
}
proc buttonbar::hilightbutton {w name} {
global info
set name [winfo toplevel $name]
if {[winfo ismapped $name]} return
set view [tabvisibility $name]
set color red
if {[info exists info(text,$name)] && [string match *hilight* [$info(text,$name) tag names end-1l+8c]]} {
set color yellow
}
if {[$w.middle.c.f$name cget -foreground] != "yellow"} {
$w.middle.c.f$name configure -foreground $color -activeforeground $color
}
if {$view < 0 && [$w.left cget -foreground] != "yellow"} {
$w.left configure -foreground $color -activeforeground $color
}
if {$view > 0 && [$w.right cget -foreground] != "yellow"} {
$w.right configure -foreground $color -activeforeground $color
}
}
proc buttonbar::tabvisibility {w name} {
set s [winfo rootx $w.middle.c]
set ts [winfo rootx $w.middle.c.f$name]
if {$ts < $s} {return -1}
if {$ts + [winfo width $w.middle.c.f$name] > $s + [winfo width $w.middle.c]} {return 1}
return 0
}
proc buttonbar::showframe {w name} {
variable buttonbar
set name [lindex [split $name .] end]
if {[$w.middle.c.f.$name cget -relief] == "raised"} return
foreach x [winfo children $buttonbar($w)] {
if {$x != $w} {pack forget $x}
}
foreach x [winfo children $w.middle.c.f] {$x configure -relief groove}
pack $buttonbar($w).$name -fill both -expand 1
$w.middle.c.f.$name configure -foreground black -activeforeground black -relief raised
}
proc buttonbar::setscrollstate {w} {
set width [winfo width $w.middle.c]
if {$width > 1 && [winfo width $w.middle.c.f] > $width} {
$w.left configure -state normal
$w.right configure -state normal
} else {
$w.left configure -foreground black -activeforeground black -state disabled
$w.right configure -foreground black -activeforeground black -state disabled
}
}
proc buttonbar::tearoff {w tab x y} {
variable buttonbar
set tab [string map "$w.middle.c.f. {}" $tab]
set rx1 [winfo rootx $w]
set ry1 [winfo rooty $w]
set rx2 [expr $rx1 + [winfo width $w]]
set ry2 [expr $ry1 + [winfo height $w]]
if {$x < ($rx1 - 20) || $x > ($rx2 + 20) || $y < ($ry1 - 20) || $y > ($ry2 + 20)} {
set win $buttonbar($w).$tab
# add your function here
closecurrent $w
}
}
proc buttonbar::tabdrag {w tab} {
set pointery [winfo pointery $tab]
set pointerx [winfo pointerx $tab]
set hi [winfo rooty $w.middle]
if {$pointery < $hi || $pointery > ($hi + [winfo height $w.middle])} return
set children [winfo children $w.middle.c.f]
set c [lsearch -exact $children $tab]
if {$pointerx < [winfo rootx $w.middle.c]} {
bind tab <Motion> {}
after 500 "[namespace current]::tabdrag $w $tab"
if {[set to [lindex $children [expr $c - 1]]] == ""} return
pack configure $tab -before $to
lower $tab $to
update idletasks
if {[tabvisibility $w [string map "$w.middle.c.f {}" $tab]] < 0} {scrollsetleft $w $tab}
return
} elseif {$pointerx > ([winfo rootx $w.middle.c] + [winfo width $w.middle.c])} {
bind tab <Motion> {}
after 500 "[namespace current]::tabdrag $w $tab"
if {[set to [lindex $children [expr $c + 1]]] == ""} return
pack configure $tab -after $to
raise $tab $to
update idletasks
if {[tabvisibility $w [string map "$w.middle.c.f {}" $tab]] > 0} {scrollsetright $w $tab}
return
}
bind tab <Motion> "[namespace current]::tabdrag $w $tab"
set in [winfo containing $pointerx $pointery]
if {$tab == $in} return
set i [lsearch -exact $children $in]
if {$i < 0} {
set to [lindex $children end]
pack configure $tab -after $to
raise $tab $to
} elseif {$i < ($c - 1)} {
set to [lindex $children [expr $c - 1]]
pack configure $tab -before $to
lower $tab $to
} elseif {$i > ($c + 1)} {
set to [lindex $children [expr $c + 1]]
pack configure $tab -after $to
raise $tab $to
}
}
if {[info level] == 0} {
pack [buttonbar::create .tabs .windows] -side top -fill x
frame .windows
pack .windows -side bottom -fill both -expand 1
foreach x {a b c d e f g h i j k l m n o} {
buttonbar::add .tabs $x
}
buttonbar::name .tabs a "tab 1"
buttonbar::name .tabs b "tab 2"
buttonbar::name .tabs c "tab 3"
buttonbar::name .tabs d "blah blah"
buttonbar::name .tabs e "test"
pack [text .windows.a.t]
pack [listbox .windows.b.l] -pady 5
pack [entry .windows.c.e] -pady 5
buttonbar::showframe .tabs a
update idletasks
wm geometry . [wm geometry .]
}this megawidget creates a row of tabs which switch between frames. you can drag the tabs to rearrange the order. it has scroll buttons for when you have too many tabs to fit in one window and also a close button to close the current tab. tabs can be dragged out of the window which will run a command (edit the tearoff proc). usage example is at the bottom--AF 24-06-03lv anyone up for writing a comparison of the various iterations of these?Also, AF, have you considered working with tklib to get your widgets into that library?
Getting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit