[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 {} {
  catch {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}

----

[RH] ''30. Oct 2005'' Please take care of non windows users. There is no
 console show
on linux. A simple check would solve this
 if { $::tcl_platform(platform) eq "windows" } {
     console show
 }

[MG] Oct 31 2005 - This is nice, though it seems to behave a little differently than I would've expected. Selecting a new colour doesn't trigger the action associated with the top button (you have to select a new colour, then click the top buttom to perform the action). Also, in most applications I've scene which have colour-selectors like this, the buttons work the other way around - the large, main button (which is often on the left, instead of above) changes colour to show the most recent selected colour, and clicking it selects that colour again for the current window/selected text/etc. And then a smaller button to the right brings up the menu to select other colours. (I added a [catch] around the ''console show'', incidently, after RH's comments above.)