WJG (21 January 2005) Now the tabs can be dragged and repositioned along along the container. Raised tab can also be highlighted. Double-B1 click the main body of the to post a popup-menu/palette, Double-1 click the tab icon to post a floating palettte. When a floating palette is posted, the tab will be hidden. Close the palette and the tab reappears.
(PBO 26 aug 2005) Fixed a bug related to withdrawing a previous tab that was detached. Now tabs (and detached windows) are no more lost when you detach several of them (when clicking red boxes).
############################################
#
# tearofftabbar.tcl
# ------------------------
#
# Copyright (C) 2005 William J Giddings
# email: giddings@freeuk.com
#
############################################
#
# 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] != "" } {
withdrawIfNeeded [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] != "" } {
withdrawIfNeeded [string tolower .[set %W::lasttab]]
}
%W raise [set %W::lasttab]
%W raisetab [set %W::lasttab]
TearoffTabBar::_placepalette %W
}
#-------
# show palette, allow movement
#-------
$pathName bind $tag.image <Double-ButtonPress-1> {
#hide previous palette
if { [set %W::lasttab] != "" } {
withdrawIfNeeded [string tolower .[set %W::lasttab]]
}
%W raise [set %W::lasttab]
%W raisetab [set %W::lasttab]
TearoffTabBar::_placepalette %W
wm overrideredirect [string tolower .[set %W::lasttab]] 0
[string tolower .[set %W::lasttab]].fra config -relief flat
focus -force [string tolower .[set %W::lasttab]]
%W move [set %W::lasttab] 0 20
}
#---------
# 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 overrideredirect .$title 1
wm withdraw .$title
.$title.fra config -relief raised
$pathName move [string totitle $title] 0 -20
"
wm withdraw .$title
wm geometry .$title ${palettewidth}x${paletteheight}
wm overrideredirect .$title 1
bind .$title <FocusIn> ".ttb raisetab $title"
return .$title
}
proc withdrawIfNeeded {w} {
if {[wm overrideredirect $w] == 1} {
#not for detached palettes
wm withdraw $w
}
}
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.
Double-Click icon for floating palette, tab will vanish.
Close floating palette to restore tab."
}
demo