1# clrpick.tcl -- 2# 3# This demonstration script prompts the user to select a color. 4# 5# RCS: @(#) $Id: clrpick.tcl,v 1.3 2001/06/14 10:56:58 dkf Exp $ 6 7if {![info exists widgetDemo]} { 8 error "This script should be run from the \"widget\" demo." 9} 10 11set w .clrpick 12catch {destroy $w} 13toplevel $w 14wm title $w "Color Selection Dialog" 15wm iconname $w "colors" 16positionWindow $w 17 18label $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." 19pack $w.msg -side top 20 21frame $w.buttons 22pack $w.buttons -side bottom -fill x -pady 2m 23button $w.buttons.dismiss -text Dismiss -command "destroy $w" 24button $w.buttons.code -text "See Code" -command "showCode $w" 25pack $w.buttons.dismiss $w.buttons.code -side left -expand 1 26 27button $w.back -text "Set background color ..." \ 28 -command \ 29 "setColor $w $w.back background {-background -highlightbackground}" 30button $w.fore -text "Set foreground color ..." \ 31 -command \ 32 "setColor $w $w.back foreground -foreground" 33 34pack $w.back $w.fore -side top -anchor c -pady 2m 35 36proc setColor {w button name options} { 37 grab $w 38 set initialColor [$button cget -$name] 39 set color [tk_chooseColor -title "Choose a $name color" -parent $w \ 40 -initialcolor $initialColor] 41 if {[string compare $color ""]} { 42 setColor_helper $w $options $color 43 } 44 grab release $w 45} 46 47proc setColor_helper {w options color} { 48 foreach option $options { 49 catch { 50 $w config $option $color 51 } 52 } 53 foreach child [winfo children $w] { 54 setColor_helper $child $options $color 55 } 56} 57