############################################
#
# Palette.tcl
# ------------------------
#
# Copyright (C) 2005 William J Giddings
# email: giddings@freeuk.com
#
############################################
#
# 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::demoMG 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://wiki.tcl.tk/9079
image create photo fp_tickle_trans -data {
R0lGODlhEAAQANUAANnZ2QAAACAfG6+sjM7BfcOyY7Kxk8q7crOyl9HFgqGV
XWFZMTw8M+Dapq2fXo+EVTAsGLS0mcy+dm1mSJKFShMTE+fktqqdXnZtRT05
JXh4ZtnRlmFaObqqYgwMDNHFgU5LOkA8KLuyfVtUMRQUFPDwzI+NdHZtQ66g
Xjs7MXd3ZHlwRlRPOA8PD0BANx8fHwMDA///////////////////////////
/////////////////////////////////yH5BAEAAAAALAAAAAAQABAAAAZ3
QIBwOAwEBEQiMTAgFAJEojBgOBQKASIREEAkFIUFkShkNByPAoRIBAQikkmB
UiESAQHLBVPIEIlCQJoNp0PxAAHCIVHzARVCROJQIxpRAkSikFQynVABInGY
Uq1YROIw0GK4WgEikRh4EYlEIaxFJBKFgQCRGAQAOw==
}
# 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_trans \
-anchor nw \
-tags icon
$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, withfpActivate $floatingPaletteToplevel ;# .pal in the demo codeAnd then bind to the toplevel, so that when it loses focus, fpDeactivate .pal is run, and fpActivate .pal is run when it gains focus
WJG (17 Jan 2005) The code for the graduated toolbar looks good. I'll have to try it. The work you've done with the registry looks interesting, must have a hack. How did you get on with the corner graphic. The samples that I included had a solid blue background (to match the bar). Have you looked at setting transparency?MG I didn't set the transparancy, mainly out of lack of time when I put this up, but it's not that difficult to you. I made a page on the Wiki here about Replace one color in an image with transparency which would do the job without a problem (though Photoshop or something like that would do it a few thousand times quicker). I'll come back later and put transparent versions of the image up w/the gradient code, and change that to use the new transparent images, when I get a few minutes. Unless someone else beats me to it, anyway :)WJG (21 Jan 2005) That would be a really good addition. The overall effect would blend into any(?) windows colour scheme.MG 21 Jan 2005 - OK, finally got off my ass and sorted that transparent image :) Yeah, it should work no matter what your colour scheme is on Windows, you don't need the default dark/pale blue title bars. (If you change it after the fpActivate command is run, though, the colours won't update until the next time you fpActivate it.) One improvement to make would be to check if the first and second colours are the same (ie, see if the title bar is one solid colour, not a gradient), and just use the -fill option on the canvas if that's the case, not the gradient code.MG, a few minutes later - Just checked, and (as long as you re-run fpActivate .pal after you change the settings), the title bar on the palette changes colour. Of course, you could then go the whole mile and change the button graphics to get their colours from the registry too. But heck, it took me a week to just make the icon transparent. I'll leave that for someone else :D
AM (17 january 2005) I tried this on Linux:
- The wm attributes command was rejected - the -topmost option is Windows-specific. So, just to get an impression, I removed that line
- Then it worked, but with one strange side effect: I run a Windows PC and an X emulator. The pallette was definitely present on the Linux machine, but the title bar was a Windows one! Including a little triangle to hide/show the contents
- Th second column of buttons was shown in a very narrow column - no text visible, presumably because of the large font used by default.
WJG (17 Jan 2005) My purpose was to replace the standard MS Windows titlebar offerings with something better suited to a rollup palette window. See my notes/comments for reference to these items. One of these days I might add a linux partition to my disk again.
