WJG Jan 16th 2005 - If the TK bag of widget goodies lacks something, then for me its a pucker floating palette. Those of use who are familiar with the Photoshop toolbox will know what I mean. In some of my applications a lot of resources are open which are placed in a BWidget notebook packed conveniently to one side of the screen. Even with the luxury of using a large monitor in high resolution just for parallel text editing still I crave more screen space for that text and less for those ever handy resources. Hence I've polished up this code for a floating palette. Next step, tear-off tabs!
############################################ # # Palette.tcl # ------------------------ # # Copyright (C) 2005 William J Giddings # email: [email protected] # ############################################ # # Description: # ----------- # Provide a genuine floating tool palette. The overall appearance was intended to blend in # with the look and feel of Windows 2000. As the code is not arcane relatively easy to follow, # interested users may need to modify values and settings to suit other platforms. # # Creation: # -------- # Palette pathName ?option value...? # # Standard Options: # ---------------- # # Widget Specific Options: # ----------------------- # # -exitcmd Command to be executed when palette withrawn. # -xpos Initial screen x-coordinate at which to create palette. # -ypos Initial screen y-coordinate at which to create palette. # -titlebackground / -titlebg Colour for titlebar background. # -width Overall width of the palette. # -height Overall height of the palette including titlebar. # -image Custom graphic to show in left side of the titlebar. (16x16 pixels) # # Returns: Pathname of the Palette container. # -------- # # Widget Commands: # -------- # pathName getframe Return pathname of the Palette container. # pathName gettitle Return pathname of the titlebar container. # pathName title <string> Set the palette title to a new value. # pathName icon <image> Change title graphic to new image. # # Bindings: # ----------------------------------- # Whilst this Megawidget is purely 100% Tk code, especial effort has been made to create a Windows 2000 # appearance. This extends to the behaviour of the titlebar bindings. These are: # # Icon Double-Button-1 Withdraw palette. # Title Motion-Button-1 Drag palette. # Rollup-button Button-1 Toggles large or small size. # # Example: # ------- # This module includes a demo proceedure. Delete and/or comment out as required. # # Note: # ---- # There is a problem with setting the transient option for the palette. # If the option is set, then the associated master window flashes. # Is this a problem with Tk8+? # Until this matter is resolved, the palette window attributes will be # to topmost. # # Future enhancements: # ------------------- # If the palette toplevel window is destroyed, then remove # the associated namespace. # ############################################ package require Tk #------- # create private widegt namspace #------- namespace eval Palette {} #------- # create floating palette #------- proc {Palette} { {pathname .pal} args } { #------- # no need to rebuild any exiting palette #------- if { [winfo exists $pathname] } { wm deiconify $pathname return } #------- # store all related variables in private namespace #------- namespace eval $pathname { set lx -1 set ly -1 set small 22 set height 230 set width 150 set exitcmd {bell} set title {Floating Palette} } #------- #local variables #------- set bg #000088 set xpos 100 set ypos 100 set image fp_tickle #------- # parse arguments #------- foreach {arg val} $args { switch [string trimleft $arg -] { exitcmd {set ${pathname}::exitcmd $val} xpos {set xpos $val} ypos {set ypos $val} titlebg - titlebackground {set bg $val} width {set ${base}::width $val} height {set ${base}::height $val} image {set image $val} } } #------- # create palette toplevel #------- toplevel $pathname wm withdraw $pathname wm overrideredirect $pathname 1 wm resizable $pathname 1 1 #------- # specify new container #------- set base $pathname.fra #------- # a few necessary graphics #------- image create photo fp_tickle -data R0lGODlhEAAQANUAAP////DwzOfktuDaptnRltHFgtHFgc7Bfcy+dsq7csOyY7uyfbqqYrS0mbOyl7Kxk6+sjK6gXq2fXqqdXqGVXZKFSo+NdI+EVXlwRnh4Znd3ZHZtRXZtQ21mSGFaOWFZMVtUMVRPOE5LOkBAN0A8KD05JTw8Mzs7MTAsGCAfGx8fHxQUFBMTEw8PDwwMDAokagMDAwAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACwAAAAAEAAQAAAGXsCXcDiMxVLEZBFyUMSUxNgjoXBChTFHgaL4XIWmgeSiQH1jDURHUWGdBZONovR9ZQgeRsVVzxhECiR1dgsgFU9fKwEWHBGIXycaGCGDMS0mIy2PZyqDQzAtnlibREEAOw== image create photo fp_close -data R0lGODlhEAAQAKIAAP///9TQyICAgEBAQAAAAAAAAAAAAAAAACwAAAAAEAAQAAADNhi63BMgyinFAy0HC3Xj2EJoIEOM32WeaSeeqFK+say+2azUi+5ttx/QJeQIjshkcsBsOp/MBAA7 image create photo fp_open -data R0lGODlhEAAQAKIAAP///9TQyICAgEBAQAAAAAAAAAAAAAAAACwAAAAAEAAQAAADMxi63BMgyinFAy0HC3XjmLeA4ngpRKoSZoeuDLmo38mwtVvKu93rIo5gSCwWB8ikcolMAAA7 #------- # the palette container frame #------- frame $base \ -borderwidth 3 \ -relief raised \ -height [set ${pathname}::height] \ -width [set ${pathname}::width] pack $base -side top -fill both -expand 1 #------- # own title bar #------- frame $base.fra1 \ -height 30 \ -background $bg pack $base.fra1 \ -anchor center \ -fill x \ -side top #------- # icon button # bindings: double click MB1 to withdraw #------- label $base.fra1.lab1 \ -anchor w \ -background $bg \ -borderwidth 0 \ -image $image pack $base.fra1.lab1 \ -anchor w \ -side left bind $base.fra1.lab1 <Double-1> { set base [winfo toplevel %W] wm withdraw $base eval [set ${base}::exitcmd ] } #------- # title holder # bindings: click and hold MB1 to drag #------- label $base.fra1.lab2 \ -anchor w \ -background $bg \ -borderwidth 0 \ -foreground #ffffff \ -text [set ${pathname}::title] \ -font {Ariel 8 bold} \ -padx 4 pack $base.fra1.lab2 \ -anchor w \ -side left bind $base.fra1.lab2 <Button-1> { set base [winfo toplevel %W] set ${base}::lx %x set ${base}::ly %y } bind $base.fra1.lab2 <ButtonRelease-1> { set base [winfo toplevel %W] set ${base}::lx -1 set ${base}::ly -1 } bind $base.fra1.lab2 <Motion> { set base [winfo toplevel %W] if { [set ${base}::lx] != -1 } { set ${base}::dx [expr %x - [set ${base}::lx]] set ${base}::dy [expr %y - [set ${base}::ly]] set ${base}::wx [winfo rootx $base] set ${base}::wy [winfo rooty $base] set ${base}::x [expr [set ${base}::wx] + [set ${base}::dx] ] set ${base}::y [expr [set ${base}::wy] + [set ${base}::dy] ] wm geometry $base +[set ${base}::x]+[set ${base}::y] } } #------- # roll-up button # bindings: click MB1 to toggle up or down #------- label $base.fra1.lab3 \ -anchor w \ -background $bg \ -borderwidth 0 \ -relief flat \ -foreground #ffffff \ -image fp_open pack $base.fra1.lab3 \ -anchor e \ -side right bind $base.fra1.lab3 <Button-1> { set base [winfo toplevel %W] if {[winfo height $base] == [set ${base}::small] } { %W configure -image fp_open wm geometry $base [set ${base}::width]x[set ${base}::height] ; update } else { %W configure -image fp_close wm geometry $base [set ${base}::width]x[set ${base}::small] ; update } } ;# end bind #------- # 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 { title {eval Palette::title $self $args} getframe {eval Palette::getframe $self} icon {eval Palette::icon $self} } } #------- # resize and locate palette, and always keep on top #------- wm geometry $pathname [set ${pathname}::width ]x[ set ${pathname}::height]+${xpos}+${ypos}; update wm attributes $pathname -topmost 1 #------- # return pathway to palette container #------- return $base } #------- # return container name #------- proc Palette::getframe {path} { return $path.fra } #------- # return titebar container #------- proc Palette::titlebar {path} { return $path.fra.fra1 } #------- # set palette title #------- proc Palette::title {path string} { $path.fra.fra1.lab2 configure -title $string } #------- # set palette image #------- proc Palette::image {path image} { $path.fra.fra1.lab1 configure -image $image } #------- # demo #------- proc Palette::demo {} { # authored in ASED it doesn't like new consoles! catch { console show } # create a master window with some controls set ::pal 0 ; # *1 radiobutton .rad1 -text "Show Palette" -variable pal -value 1 -command {wm deiconify .pal} radiobutton .rad2 -text "Hide Palette" -variable pal -value 0 -command {wm withdraw .pal} pack .rad1 .rad2 -anchor w -side top # create palette Palette .pal -exitcmd {set pal 0} # fill the frame from the bottom upwards set base [frame [.pal getframe].fr3] pack $base -side bottom -fill both -expand 1 pack [button $base.but1 -text "Big Button" -command "puts \{Big Button\}"] -fill x -expand 1 # create two sets of buttons # left set base [frame [.pal getframe].fr1] pack $base -side left -anchor nw -fill both -expand 1 for {set i 0} {$i <= 7} {incr i} { pack [button $base.but$i -text "Button (A,$i)" -command "puts (A,$i)"] -fill x -expand 1 } # right set base [frame [.pal getframe].fr2] pack $base -side right -anchor ne -fill both -expand 1 for {set i 0} {$i <= 7} {incr i} { pack [button $base.but$i -text "Button (B,$i)" -command "puts (B,$i)"] -fill x -expand 1 } } Palette::demo
MG Jan 15th 2005 - There is actually some native support in Windows for palettes via
wm attribute $toplevel -toolwindow 1
(which can be combined with -toplevel 1 to get a similar effect).
WJG Yes, I'm aware of this but I really do want that roll-up effect.
MG Sure :) Added a small fix to the demo proc, where the "pal" variable set was local and not global, so the radiobutton wasn't selected.
MG With Windows (or at least XP SP2, I haven't tested it elsewhere) and the registry package, along with the gradient code from Gradients Color Transitions, you can also do more native gradient titlebars (by making the titlebar a canvas and binding the movement, etc, to that. A small change is needed in the Gradient code, though; it needs to add the tag 'move' as well as the tag 'gradient'). Here's a quick bit of code to do it (thrown together from a half-hour's playing in the wish console, and only lightly tested)...
# make sure we have the registry package
package require registry
# This replaces everything from "own title bar" (inclusive) to "Here comes the overloaded widget proc" (exclusive)
source gradient.tcl ;# the code in http://mini.net/tcl/9079
# Title bar
frame $base.fra1 -height 30
pack $base.fra1 \
-anchor center \
-fill x \
-side top
set canv [canvas $base.fra1.c \
-width [expr {[set ${pathname}::width]-5}] \
-height 20 -highlightthickness 0 \
-borderwidth 0]
pack $canv -side left -anchor nw -fill x
$canv create image 2 2 \
-image fp_tickle \
-anchor nw \
-tags icon ;# image should be transparent
$canv create text 18 2 \
-text [set ${pathname}::title] \
-font {Arial 8 bold} -tags [list move titletxt] \
-anchor nw
$canv create image [expr {[set ${pathname}::width]-7}] 2 \
-image fp_open -anchor ne -tags toggleBtn
$canv bind move <Button-1> {
set base [winfo toplevel %W]
set ${base}::lx %x
set ${base}::ly %y
}
$canv bind move <ButtonRelease-1> {
set base [winfo toplevel %W]
set ${base}::lx -1
set ${base}::ly -1
}
$canv bind move <Motion> {
set base [winfo toplevel %W]
if { [set ${base}::lx] != -1 } {
set ${base}::dx [expr %x - [set ${base}::lx]]
set ${base}::dy [expr %y - [set ${base}::ly]]
set ${base}::wx [winfo rootx $base]
set ${base}::wy [winfo rooty $base]
set ${base}::x [expr [set ${base}::wx] + [set ${base}::dx] ]
set ${base}::y [expr [set ${base}::wy] + [set ${base}::dy] ]
wm geometry $base +[set ${base}::x]+[set ${base}::y]
}
}
$canv bind icon <Double-1> {
set base [winfo toplevel %W]
wm withdraw $base
eval [set ${base}::exitcmd ]
break;
}
$canv bind toggleBtn <Button-1> {
set base [winfo toplevel %W]
if {[winfo height $base] == [set ${base}::small] } {
%W itemconfigure toggleBtn -image fp_open
wm geometry $base [set ${base}::width]x[set ${base}::height] ; update
} else {
%W itemconfigure toggleBtn -image fp_close
wm geometry $base [set ${base}::width]x[set ${base}::small] ; update
}
break;
} ;# end bindYou then need to add these three procs:
proc col {rgb} {
set r [lindex $rgb 0]; set g [lindex $rgb 1]; set b [lindex $rgb 2]
format #%04X%04X%04X [expr {($r*255)+($r*2)}] [expr {($g*255)+($g*2)}] [expr {($b*255)+($b*2)}]
}
proc fpActivate {w} {
set canv $w.fra.fra1.c
transx::paint_canvas $canv x [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} ActiveTitle]] [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} GradientActiveTitle]]
$canv lower gradient
$canv itemconfigure titletxt -fill [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} TitleText]]
}
proc fpDeactivate {w} {
set canv $w.fra.fra1.c
transx::paint_canvas $canv x [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} InactiveTitle]] [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} GradientInactiveTitle]]
$canv lower gradient
$canv itemconfigure titletxt -fill [col [registry get {HKEY_CURRENT_USER\Control Panel\Colors} InactiveTitleText]]
}Then put the active colours on the bar, with
fpActivate $floatingPaletteToplevel ;# .pal in the demo code
And then bind to the toplevel, so that when it loses focus, fpDeactivate .pal is run, and fpActivate .pal is run when it gains focus