[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. 

[WJG] 31st October, 2005

Here is a revised version that supports multiple widget instances.

======
 ############################################ 
 # colourpicker.tcl
 # ------------------------
 # Written by: William J Giddings
 # 1st November, 2005
 ############################################ 
 # Description:
 # -----------
 # Select a colour from a predefined palette.
 # The selector doesn't assign colours directly, but to designated variables.
 # 
 # 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.
 #
 # Modifications:
 # -------------
 # Multiple buttons can be used, the popup is recreated each time required in order to 
 # re-assaing values to widget assigned cariables: e.g. $base.cp1 -> fg ; $base.cp2 -> bg
 #  
 ############################################

 set rundemo yes

 namespace eval clrpick {}

 # default settings
 # menu button swatch size
 set clrpick::height 14
 set clrpick::width 14
 
 # sample colour palettes, a list comprising 'name values..'
 set clrpick::palette(1) "White white Grey grey Black Black Red red Orange orange Yellow yellow Green green Blue blue Magenta magenta Violet violet Purple purple"
 set clrpick::palette(2) "white #ffffff grey #dddddd black #000000 red #ff0000 green #00ff00 blue #0000ff"
 set clrpick::palette(3) "Blue #ffdddd Green #ddffdd Red #ddddff Orange #ffeedd Yellow #ffff00 White #ffffff Grey #cccccc A #dcffee B #ffd200 C #caeff9 D #f9caf5 E #000000" 

 # clrpick::vars() is an array created on the fly to store the names of associated variables

 # some icons for the apply button
 # a marking pen, ie background
 image create photo _clrpick_marker -data R0lGODlhEAALAMIHAAAAAAAAgICAgAD/AMDAwNTQyP//AP///ywAAAAAEAALAAADLli6C/4sKjAqkPPMcTE4BzFhxRcSAVmCBNpJAhG7KiALwisBBu7UhoNB54GoCgkAOw==
 # text icon, ie foreground
 image create photo _clrpick_text -data R0lGODlhEAALAKEEAAAAAICAgAD/ANTQyCH+FUNyZWF0ZWQgd2l0aCBUaGUgR0lNUAAsAAAAABAACwAAAiqcH2DAfcfCElS9xKCwrwG5PEYSYKKYDdE5fi2Heg14uUjawYu946pjKAAAOw==

 #---------------
 # 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, unique for each button
 #---------------
 proc clrpick::popup {w palette args} {
  # create a new popup every time its needed to re-assign variables
  set pathName .cp
  if {[winfo exist $pathName]} {destroy $pathName}
    # create a popup menu, to be placed under the calling button
    eval menu $pathName $args
    # column break counter
    set k 0
    # create menu option for each colour in the palette
    foreach {i j} $palette {
      if {[incr k] > "6"} {
        set cb 1
        set k 0
      } else {
        set cb 0
      }
      # create appropriate colour swatch
      swatch $j $j $clrpick::height $clrpick::width
      # produce individual button
      $pathName add command \
        -columnbreak $cb \
        -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 $pathName $x $y
 }

 #---------------
 # handle menu selection, set active colour and change widget swatch
 # called from within: clrpick::popup
 # w     widget path
 # clr   variable to be set
 #---------------
 proc clrpick::pick {w clr} {
  swatch $w $clr [image height swatch_$w] [image width swatch_$w]
  $w configure -image swatch_$w
  eval set $clrpick::vars([winfo parent $w]) $clr
 }

 #---------------
 # create new widget instance
 # w     widget path
 # clr   variable to be set
 # args  passed to button 
 #---------------
 proc ClrPick {w clr palette args } {
  set clrpick::vars($w) $clr
  # set size of button colour swatch
  array set b1 "w 6 h 18"
  frame $w
  eval button $w.b1 $args 
  clrpick::swatch $w.b2 [set $clr] $b1(w) $b1(h)
  button $w.b2 \
    -image swatch_$w.b2 \
    -command "clrpick::popup $w.b2 $palette -tearoff 0" \
    -relief flat \
    -borderwidth 0 \
    -relief flat
  pack $w.b1 $w.b2
  return $w
 }

 #---------------
 # the unbiqitous demo
 #---------------

 proc demo {} {

  # put demo vars in global space
  set ::clr1 white
  set ::clr2 black

  pack [frame .fr1] -side top -fill x  

  # text background colour picker
  ClrPick .fr1.cp1 ::clr1 \"$clrpick::palette(1)\" -image _clrpick_marker  -relief flat  -borderwidth 0 \
      -command {
        .txt tag add hl$::clr1 sel.first sel.last
        .txt tag configure hl$::clr1 -background $::clr1
        }
  pack .fr1.cp1 -side left -anchor nw

  # text foreground colour picker
  ClrPick .fr1.cp2 ::clr2 \"$clrpick::palette(2)\" -image _clrpick_text  -relief flat  -borderwidth 0 \
      -command {
        .txt tag add pc$::clr2 sel.first sel.last
        .txt tag configure pc$::clr2 -foreground $::clr2
        }
  pack .fr1.cp2 -side left -anchor nw
  
  pack [text .txt -background $::clr1 -foreground $::clr2 ] -fill both  
  .txt insert end "Om Gate Gate Paragate Parasamgate Bodhi Svaha"
 }

 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
 }

[WJG] 31/10/05 [RH] I've taken your advice into account and have placed checks on the 'console show' command. I ususally send debugging messages out to the console, so I've left these in.

[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 seen 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.)

[WJG] 31/10/05 If you want, the code could be hacked to change the packing of the sub-widgets although I prefer the layout as I have it. For me the visual logic of moving horizontally is to have a distinct change in function whereas vertical alignment implies subordination. If you opt for a horizontal arrangement then the swatch size would need modified from 6hx18w to 18hx6w or thereabouts. The 'ideal' that I was working to was 18 x 18 pixels, allowing for a 2 pixel border all round.

[WJG] 01/11/05 Now allows each instance to have its own associated palette.

<<categories>> GUI