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 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 are set 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 bind
You 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
AM (17 january 2005) I tried this on Linux:
[ Category GUI ]