[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 clrw args } { array set b1 "w 8 h 18" frame $w eval button $w.b1 $args clrpick::swatch $w.b2 white $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}