mingw/lib/tk8.5/demos/clrpick.tcl

   1 # clrpick.tcl --
   2 #
   3 # This demonstration script prompts the user to select a color.
   4
   5 if {![info exists widgetDemo]} {
   6     error "This script should be run from the \"widget\" demo."
   7 }
   8
   9 package require Tk
  10
  11 set w .clrpick
  12 catch {destroy $w}
  13 toplevel $w
  14 wm title $w "Color Selection Dialog"
  15 wm iconname $w "colors"
  16 positionWindow $w
  17
  18 label $w.msg -font $font -wraplength 4i -justify left -text "Press the buttons below to choose the foreground and background colors for the widgets in this window."
  19 pack $w.msg -side top
  20
  21 ## See Code / Dismiss buttons
  22 set btns [addSeeDismiss $w.buttons $w]
  23 pack $btns -side bottom -fill x
  24
  25 button $w.back -text "Set background color ..." \
  26     -command \
  27     "setColor $w $w.back background {-background -highlightbackground}"
  28 button $w.fore -text "Set foreground color ..." \
  29     -command \
  30     "setColor $w $w.back foreground -foreground"
  31
  32 pack $w.back $w.fore -side top -anchor c -pady 2m
  33
  34 proc setColor {w button name options} {
  35     grab $w
  36     set initialColor [$button cget -$name]
  37     set color [tk_chooseColor -title "Choose a $name color" -parent $w \
  38         -initialcolor $initialColor]
  39     if {[string compare $color ""]} {
  40         setColor_helper $w $options $color
  41     }
  42     grab release $w
  43 }
  44
  45 proc setColor_helper {w options color} {
  46     foreach option $options {
  47         catch {
  48             $w config $option $color
  49         }
  50     }
  51     foreach child [winfo children $w] {
  52         setColor_helper $child $options $color
  53     }
  54 }