WJG (17 Janaury 2005)
Notebooks provide really useful access to pages of forms and the use of page tabs is a really quick and easily way to switch between those forms. But, what if we want that sort visual style of access, which will pull up extra boxes of tools, forms or just whatever we can fit in a widget container. 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, I don't wnat to prune our trees on such a cold and damp day, I've spent the morning putting the bits together. 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 create a floating palette see XXXXX.
############################################ # # tearofftabbar.tcl # ------------------------ # # Copyright (C) 2005 William J Giddings # email: [email protected] # ############################################ # # Description: # ----------- # Provide a horisontal notebook tab-bar megawidget that allows # floating palettes to appear rather than book pages. Conceptually # this is similar a standard to a menu button but enables the author # is now abled 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