1# clrpick.tcl -- 2# 3# This demonstration script prompts the user to select a color. 4# 5# RCS: @(#) $Id$ 6 7if {![info exists widgetDemo]} { 8 error "This script should be run from the \"widget\" demo." 9} 10 11package require Tk 12 13set w .clrpick 14catch {destroy $w} 15toplevel $w 16wm title $w "Color Selection Dialog" 17wm iconname $w "colors" 18positionWindow $w 19 20label $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." 21pack $w.msg -side top 22 23## See Code / Dismiss buttons 24set btns [addSeeDismiss $w.buttons $w] 25pack $btns -side bottom -fill x 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