############################################ 
 # 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}

 console show

 if { $::tcl_platform(platform) eq "windows" } {
     console show
 }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References