WJG 30th October, 2005
There a number of colour pickers out there including the one shipped within the tcl/tk installation itself. However, I wanted something a little more polished and re-usable, hence ClrPick.
############################################
# colourpicker.tcl
# ------------------------
# Written by: William J Giddings
# 30th October, 2005
############################################
# Description:
# -----------
# Select a colour from a predefined palette.
#
# Proceedures:
# -----------
# clrpick::swatch {name clr h w} create colour swatched for use in popupmenu and ClpPick widget.
# clrpick::popup {w} display palette popup menu
# clrpick::pick {w clr} respond to popup menu choise
# ClrPick {w clrw args } create instance of ClrPick megawidget
#
# Note:
# ----
# Two buttons are held in a frame.
# The lower button displays a colour swatch of the active colour. Whereas
# the upper button is used to apply the new colour.
#
############################################
set rundemo yes
namespace eval clrpick {}
# default settings
# menu button swatch size
set clrpick::height 14
set clrpick::width 14
# the colour palette
set clrpick::palette "White white Grey grey Black Black Red red Orange orange Yellow yellow Green green Blue blue Magenta magenta Violet violet Purple purple"
# Alternatively:
# set clrpick::palette "white #ffffff grey #dddddd black #000000 red #ff0000 green #00ff00 blue #0000ff"
# the active colour
set clrpick::clr white
# icon for the apply button
image create photo _clrpick -data R0lGODlhEgANAMIHAAAAAAAAgICAgAD/AMDAwNTQyP//AP///yH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAsAAAAABIADQAAAzFYutz+BcgJGxgY1HjU1RVwHIS3iSQRbFwagJBAyCoMAbMg2A9g6BKW72Dg3SisZCMBADs=
#---------------
# create colour swatches
#---------------
proc clrpick::swatch {name clr h w} {
set topBorderColor gray50
set bottomBorderColor gray75
image create photo swatch_$name -height $h -width $w
swatch_$name put $topBorderColor -to 0 0 $w 1
swatch_$name put $topBorderColor -to 0 1 1 $h
swatch_$name put $bottomBorderColor -to 0 [expr $h -1] $h $h
swatch_$name put $bottomBorderColor -to [expr $w -1] 1 $w $w
swatch_$name put $clr -to 1 1 [expr $w - 1] [expr $h -1]
}
#---------------
# show the popup menu
#---------------
proc clrpick::popup {w} {
# create popupmen if one doesn't exist already
if {![winfo exist .cp]} {
set pathName .cp
# create a popup menu, to be placed under the calling button
menu $pathName -tearoff 0
foreach {i j} $clrpick::palette {
swatch $j $j $clrpick::height $clrpick::width
$pathName add command \
-compound left \
-label $i \
-image swatch_$j \
-command "clrpick::pick $w $j"
}
}
# place picker window close to calling button
set x [winfo rootx $w]
set y [expr [winfo rooty $w]+ [winfo height $w]]
tk_popup .cp $x $y
}
#---------------
# handle menu selection, set active colour and change widget swatch
#---------------
proc clrpick::pick {w clr} {
swatch $w $clr [image height swatch_$w] [image width swatch_$w]
$w configure -image swatch_$w
set clrpick::clr $clr
}
#---------------
# create new widget instance
#---------------
proc ClrPick {w clr args } {
array set b1 "w 8 h 18"
frame $w
eval button $w.b1 $args
clrpick::swatch $w.b2 $clr $b1(w) $b1(h)
button $w.b2 -image swatch_$w.b2 -command "clrpick::popup $w.b2" -relief flat -borderwidth 0 -relief flat
pack $w.b1 $w.b2
return $w
}
#---------------
# the unbiqitous demo
#---------------
proc demo {} {
console show
ClrPick .cp1 $clrpick::clr -image _clrpick -relief flat -borderwidth 0 \
-command {
puts "Do something with colour \"$clrpick::clr\"."
.txt configure -background $clrpick::clr
}
pack .cp1 -side top -anchor nw
pack [text .txt] -fill both
}
if {$rundemo} {demo}