WJG (17 January 2005)
Notebook widgets provide a quick and easily way to switch between forms. But, what if we want that sort visual style of access to windows, rather than pages?
As I don't have to get my daughter from school yet and I don't start work till tonight and the missus has gone out for lunch with her mates and.. Well, the truth is that I don't wnat to prune our trees on such a cold and damp day. So, I've spent the morning putting the bits together for such a widget. I'm sure that, indeed I hope that, other Tickler's out there will play-n-hack with this code. Next step, modify the palette window creation proc to produce a floating roll-up palette (See [L1 ]).
WJG (21 January 2005) Now the tabs can be dragged and repositioned along along the container. Raised tab can now be highlighted.
############################################ # # tearofftabbar.tcl # ------------------------ # # Copyright (C) 2005 William J Giddings # email: [email protected] # ############################################ # # Description: # ----------- # Provide a horizontal notebook tab-bar megawidget that allows # floating palettes to appear rather than book pages. Conceptually # this is similar to a standard menu button but the author # is now able to embed other resources into the palette. # # Creation: # -------- # TearoffTabBar pathName ?option value...? # # Standard Options: # ---------------- # -relief (default = flat) # -borderwidth (default = 0) # # Widget Specific Options: # ----------------------- # -lbevel Tab left bevel (default = 2) # -rbevel Tab right bevel (default = 2) # -font Tab font (default = Ariel 10) # -height Set base tab height (default = 20) # -width Set base tab width (default = 75) # -shift Set rise/drop of tags (default = +/-3) # # Returns: # -------- # Pathname of the tabbar container. # # Widget Commands: # -------- # pathName add Add new tab to the bar. Returns pathname of the palette created. # pathName raisetab Raise tab to topmost position. # pathName lowertab Lowet tab. # # Bindings: # -----------------------------------# # Tab Button-1 Raise tab and show palette. Lower previously selected tab. # Palette Focus-In Raise associated tab. # # Example: # ------- # This module includes a demo proceedure. Delete and/or comment out as required. # # Note: # ---- # Work still in progress. # # Future enhancements: # ------------------- # 1) Improve/complete this notes section. # 2) Combine with floating-palettes. # 4) Means of tracking available palettes per tabbar widget. # ############################################ package require Tk namespace eval TearoffTabBar {} proc TearoffTabBar { pathName args} { #------- # create private namespace and set defaults #------- namespace eval ${pathName} { set height 20 set width 75 set relief flat set borderwidth 0 set font {Ariel 10} set tabbg SystemButtonFace set tabhighlight #ddddcc set lbevel 2 ;# tab drawing parameter set rbevel 15 set shift 3 set image "" set lastx 0 ;# mouse inpt set lasty 0 set lasttab "" ;# hide/lower previous items set tabmin_x "" ;# used in testing during dragging the tab in the tabbar set tabmax_x "" } #------- # parse args #------- foreach {arg val} $args { puts "$arg : $val" switch -- $arg { -height - -relief - -borderwidth - -lbevel - -rbevel - -font { set ${pathName}::[string trimleft $arg -] $val } } } #------- # create container #------- canvas $pathName \ -height [set ${pathName}::height] \ -relief [set ${pathName}::relief] \ -borderwidth [set ${pathName}::borderwidth] #------- # Here comes the overloaded widget proc: #------- rename $pathName _$pathName ;# keep the original widget command proc $pathName {cmd args} { set self [lindex [info level 0] 0] ;# get name I was called with switch -- $cmd { add {eval TearoffTabBar::add $self $args} raisetab {eval TearoffTabBar::raisetab $self $args} lowertab {eval TearoffTabBar::lowertab $self $args} default {uplevel 1 _$self $cmd $args} } } return $pathName } #------- # add new items to the bar #------- # currently creating tab at disired location, this perhaps causing problems # create tab, then move to xpos proc TearoffTabBar::add {pathName args} { #------- # set some defaults #------- set xpos 1 set height [set ${pathName}::height] set width 75 set title "NEW" set font {Ariel 10} set tabbg SystemButtonFace set image "" set palettewidth 100 set paletteheight 150 #------- # parse args #------- foreach {arg val} $args { switch -- $arg { -tag - -xpos - -height - -width - -title - -image - -font { set [string trimleft $arg -] $val} -tabbg - -palettewidth - -paletteheight - -tabbackground { set tabbg $val} } } #------- # add local vars, make this easier to read #------- set lbevel [set ${pathName}::lbevel] set rbevel [set ${pathName}::rbevel] #------- # draw the tab #------- set tmp $xpos set xpos 0 # 1) background polygon $pathName create polygon \ 0 $height 0 $lbevel \ 0 $lbevel $lbevel 0 \ $lbevel 0 [expr $width - $rbevel] 0 \ [expr $width - $rbevel] 0 $width $rbevel \ $width $height \ -fill $tabbg \ -outline $tabbg \ -tag "$tag $tag.tab" #2) tab outline #2a) left line # #| #| #| $pathName create line \ $xpos $height \ $xpos $lbevel \ -fill white \ -tag $tag #2b) left bevel #/ #| #| #| $pathName create line \ $xpos $lbevel \ [expr $xpos + $lbevel] 0 \ -fill white \ -tag $tag #2c) top line #/------------- #| #| #| $pathName create line \ [expr $xpos + $lbevel] 0 \ [expr $xpos + $width - $rbevel] 0 \ -fill white \ -tag $tag #2d) right bevel #/-------------\ #| \ #| \ #| $pathName create line \ [expr $xpos + $width - $rbevel] 0 \ [expr $xpos + $width] $rbevel \ -fill #888888 \ -tag $tag #2e) right line #/-------------\ #| \ #| \ #| | $pathName create line \ [expr $xpos + $width] $rbevel \ [expr $xpos + $width] $height \ -fill #888888 \ -tag $tag #3) add icon if {$image != "" } { \ $pathName create image \ [expr $xpos + 4] 11 \ -image $image \ -anchor w \ -tag "$tag $tag.image" } # 4) add text $pathName create text \ [expr $xpos + 22] 11 \ -text $title \ -anchor w \ -font $font \ -tag "$tag $tag.text" #--------- # shuffle the tabs down # -------- $pathName move $tag $tmp 2 #--------- # add bindings #--------- #------- # select & raise tab #------- $pathName bind $tag <ButtonPress-1> { set tags [lindex [%W gettags current] 0] #hide previous palette if { [set %W::lasttab] != "" } { wm withdraw [string tolower .[set %W::lasttab]] } %W raise $tags %W raisetab $tags set %W::lasttab $tags set %W::lastx %x set %W::lasty %y update idletasks set %W::x %x #minmax %W #puts "$tags %x min [set %W::tabminx] max [set %W::tabmaxx]" } #------- # show palette #------- $pathName bind $tag <Double-ButtonPress-1> { #hide previous palette if { [set %W::lasttab] != "" } { wm withdraw [string tolower .[set %W::lasttab]] } %W raise [set %W::lasttab] %W raisetab [set %W::lasttab] TearoffTabBar::_placepalette %W } #--------- # drag tab to different location #--------- $pathName bind $tag <Button1-Motion> { set tags [lindex [%W gettags current] 0] drag.canvas.item %W $tags %x -1 #test to see if torn-ff } #------- # show palette #------- $pathName bind %tag <ButtonRelease-1> { wm deiconify [string tolower .[set %W::lasttab]] #TearoffTabBar::_placepalette %W set %W::lastx %x set %W::lasty %y } #------- # create palette #------- set title [string tolower $title] toplevel .$title wm transient .$title . wm title .$title "Palette: $title" wm protocol .$title WM_DELETE_WINDOW "wm withdraw .$title" wm withdraw .$title wm geometry .$title ${palettewidth}x${paletteheight} wm overrideredirect .$title 1 bind .$title <FocusIn> ".ttb raisetab $title" return .$title } proc drag.canvas.item {w item x y} { #test for locked axis, -1 = locked if {$x} { set dx [expr {$x - [set ${w}::lastx]}] } else { set dx 0 } if {$y} { set dy [expr {$y - [set ${w}::lasty]}] } else { set dy 0 } #test before moving if {[inside $w $item $dx $dy]} { puts inside $w move $item $dx $dy } set ${w}::lastx $x set ${w}::lasty $y } proc inside {w item dx dy} { #canvas extents set can(minx) 2 set can(miny) 2 set can(maxx) [expr [winfo width $w ] - 3 ] set can(maxy) [expr [winfo height $w ] - 0 ] #item coords set item [$w coords $item] #check min values foreach {x y} $item { set x [expr $x + $dx] set y [expr $y + $dy] if {$x < $can(minx)} { return 0 } if {$y < $can(miny)} { return 0 } if {$x > $can(maxx)} { return 0 } if {$y > $can(maxy)} { return 0 } } #puts $item return 1 } #------- # move tag up 5 pixels #------- proc TearoffTabBar::raisetab {pathName tag} { catch { $pathName lowertab [set ${pathName}::lasttab] } $pathName raise $tag $pathName move $tag 0 -[set ${pathName}::shift] set ${pathName}::lasttab $tag $pathName itemconfigure $tag.tab -fill [set ${pathName}::tabhighlight] } #------- # move tag down 5 pixels #------- proc TearoffTabBar::lowertab {pathName tag} { $pathName move $tag 0 [set ${pathName}::shift] $pathName lower $tag [set ${pathName}::lasttab] $pathName itemconfigure $tag.tab -fill [set ${pathName}::tabbg] } #------- # position palette window, called by tab bindings #------- proc TearoffTabBar::_placepalette {w} { set cc "" set aa [lindex [$w gettags current] 0 ] foreach item [$w coords $aa ] { set item [string trimright $item ".0"] lappend cc $item } set maxx 0 foreach {x y} $cc { if {$x > $maxx} { set maxx $x } } set aa [string tolower $aa] wm geometry .$aa +[expr [winfo rootx $w] + $maxx -90]+[expr [winfo rooty $w]+25] wm deiconify .$aa update } ################################################################################ # test block ################################################################################ proc demo {} { pack [TearoffTabBar .ttb -rbevel 15] -fill x pack [text .txt -font {Ariel 12} ] -fill both -expand 1 set x 5 #------- # create some initial graphics #------- image create photo im_red -data R0lGODlhDAAMAJEAAP////8AAAAAAAAAACwAAAAADAAMAAACCoyPqcvtD6OclBUAOw== image create photo im_green -data R0lGODlhDAAMAJEAAP///wD/AAAAAAAAACwAAAAADAAMAAACCoyPqcvtD6OclBUAOw== image create photo im_blue -data R0lGODlhDAAMAJEAAP///wAA/wAAAAAAACwAAAAADAAMAAACCoyPqcvtD6OclBUAOw== # Scotland Wales Ireland Eire foreach item {England Scotland Wales Ireland Eire} { .ttb add -title $item -font {Ariel 8} -xpos $x -width 90 -tag $item -image im_red .ttb lowertab $item incr x 75 #add some palette widgets pack [frame .[string tolower $item].fra -height 150 -width 100 -relief raised -borderwidth 2] -fill both -expand 1 pack [label .[string tolower $item].fra.lab1 -text $item -width 15 -borderwidth 2 -relief ridge] pack [label .[string tolower $item].fra.lab2 -text $item -width 15 -borderwidth 2 -relief ridge] pack [label .[string tolower $item].fra.lab3 -text $item -width 15 -borderwidth 2 -relief ridge] } .txt insert end \ "Tearoff Tabbar. Click on a tab... Drag left/right to move. Double-Click for popup-palette." } demo