WJG (17 Janaury 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 ]).
############################################ # # 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 lbevel 2 set rbevel 15 set shift 3 set image "" set lasttab "" } #------- # 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 #------- 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 "" #------- # parse args #------- foreach {arg val} $args { switch -- $arg { -tag - -xpos - -height - -width - -title - -image - -font { set [string trimleft $arg -] $val} -tabbg - -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 #------- # 1) background polygon $pathName create polygon \ $xpos $height $xpos $lbevel \ $xpos $lbevel [expr $xpos + $lbevel] 0 \ [expr $xpos + $lbevel] 0 [expr $xpos + $width - $rbevel] 0 \ [expr $xpos + $width - $rbevel] 0 [expr $xpos + $width] $rbevel \ [expr $xpos + $width] $height \ -fill $tabbg \ -outline $tabbg \ -tag $tag # 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 } # 4) add text $pathName create text \ [expr $xpos + 22] 11 \ -text $title \ -anchor w \ -font $font \ -tag $tag #--------- # shuffle the tabs down # -------- $pathName move $tag 0 2 #--------- # add bindings #--------- $pathName bind $tag <ButtonPress-1> { set cc "" set aa [lindex [%W gettags current] 0 ] %W raise $aa %W raisetab $aa 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 } #------- # create palette #------- toplevel [string tolower .$title] wm transient [string tolower .$title] . wm title [string tolower .$title] "Palette: $title" wm protocol [string tolower .$title] WM_DELETE_WINDOW "wm withdraw [string tolower .$title]" wm withdraw [string tolower .$title] bind [string tolower .$title] <FocusIn> ".ttb raisetab $title" return [string tolower .$title] } #------- # 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 } #------- # move tag down 5 pixels #------- proc TearoffTabBar::lowertab {pathName tag} { $pathName move $tag 0 [set ${pathName}::shift] $pathName lower $tag [set ${pathName}::lasttab] } ################################################################################ # test block ################################################################################ proc demo {} { pack [TearoffTabBar .ttb -rbevel 2] -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== 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 } .txt insert end "Tearoff Tabbar.\n\nClick on a tab..." } demo