# Copyright (c) 2005, Rüdiger Härtel # All Rights Reservered # # # This code is freely distributable without restriction, but is # provided as-is with no warranty expressed or implied. # # Thanks to Bryan Oakley for his megawidget framework # he provided with his combobox in pure tcl. # # # This widget provides an interface for changing text attributes. # If the tooltip package is available it uses it for the # foreground and background images. # The text for the tooltip is taken from the message catalog. # # Requirements: # # dkffont.tcl (http://people.man.ac.uk/~zzcgudf/tcl/mwidx.html#fontdlg) # tooltip (only used if available, see tklib) # # Options: # # -label text for the label # -labelwidth width of the label for alignment # -textwidth textwidth for showing the font information # -fontvariable reference for the font variable # -fgvariable reference for the font variable # -bgvariable reference for the font variable # -fgimage image for the foreground button # -bgimage image for the background button # -type fontFgBg # # Commands: # # cget {-font|-bg|-fg} get selected font, background or foreground # # ## source dkffont.tcl package require msgcat msgcat::mcset de "Font" Zeichensatz msgcat::mcset de "Select Foreground" Vordergrundfarbe msgcat::mcset de "Select Background" Hintergrundfarbe namespace eval textAttribSel { variable widgetCommands image create photo bg -data { R0lGODlhIAAgAKEDAAAAALOzs/W3EP///yH5BAEKAAMALAAAAAAgACAAAAJd nI+py+0Po5y0woCz3oHyn3ngJ45baYZTeq5sBsSy82bCfQN0HeD5XvMJdA1e z0dkGIXJxRIJfDGjrGmRZ5UAhFxcE7Ltcr+PsBg6MZ9/6TVaK4vLZ5a6/Y7P 6ysFADs= } image create photo fg -data { R0lGODlhIAAgAKEDAAAAALOzs/W3EP///yH5BAEKAAMALAAAAAAgACAAAAJl nI+py+0Po5y0QoCz3oACAYai2E3fiIKldKbjGrVuCF/z691kwPeOfAP0fA3g TDgM/HS0pLLIVDmXUeSQyrQSGUaXlofVfZ9cjhkznTjX2wibTXmv4/Ikvd6G 4K+Wvv8PGChYUQAAOw== } } # ::textAttribSel::textAttribSel -- # # This is the command that gets exported. It creates a new # textAttribSel widget. # # Arguments: # # w path of new widget to create # args additional option/value pairs # (eg: -background white, etc.) # # Results: # # It creates the widget and sets up all of the default bindings # # Returns: # # The name of the newly create widget proc textAttribSel::textAttribSel { w args } { eval Build $w $args } # ::textAttribSel::Build -- # # This does all of the work necessary to create the basic # textAttribSel. # # Arguments: # # w widget name # args additional option/value pairs # # Results: # # Creates a new widget with the given name. Also creates a new # namespace patterened after the widget name, as a child namespace # to ::textAttribSel # # Returns: # # the name of the widget proc textAttribSel::Build { w args } { namespace eval ::textAttribSel::$w { variable widgets set widgets(foo) foo ;# coerce into an array unset widgets(foo) } upvar ::textAttribSel::${w}::widgets widgets set options(-label) "" set options(-labelwidth) 10 set options(-textwidth) 20 set options(-fontvariable) "" set options(-fgvariable) "" set options(-bgvariable) "" set options(-fgimage) fg set options(-bgimage) bg set options(-type) fontFgBg # defaults, normally the values # are taken from the variables set initialfont "Helvetica 12" set initialfg "black" set initialbg "white" # error checking if { [llength $args] % 2 != 0} { error "wrong number of arguments" } # initialize variables foreach {arg value} $args { set options($arg) $value } # if variables already have values # take these as initial values for the widgets if { $options(-fontvariable) ne "" } { unset initialfont upvar $options(-fontvariable) initialfont } if { $options(-fgvariable) ne "" } { unset initialfg upvar $options(-fgvariable) initialfg } if { $options(-bgvariable) ne "" } { unset initialbg upvar $options(-bgvariable) initialbg } # build GUI frame $w -takefocus 0 -class textAttribSel set widgets(this) $w label $w.l -text $options(-label) -width $options(-labelwidth) \ -anchor w -justify left text $w.t -height 1 -border 1 -width $options(-textwidth) \ -background $initialbg -foreground $initialfg set widgets(text) $w.t button $w.font -text [msgcat::mc Font] \ -command [list textAttribSel::ShowFontSel \ $w $options(-fontvariable)] button $w.fg -relief flat -overrelief solid -border 1 \ -image $options(-fgimage) \ -command [list textAttribSel::ShowColorSel \ $w fg $options(-fgvariable)] button $w.bg -relief flat -overrelief solid -border 1 \ -image $options(-bgimage) \ -command [list textAttribSel::ShowColorSel \ $w bg $options(-bgvariable)] if { [lsearch [package names] tooltip] > -1 } { package require tooltip package require msgcat tooltip::tooltip $w.fg [msgcat::mc "Select Foreground"] tooltip::tooltip $w.bg [msgcat::mc "Select Background"] } grid $w.l $w.t $w.font $w.fg $w.bg -padx 5 -sticky w switch -- $options(-type) { fontFgBg { # standard case } fontFg { destroy $w.bg } fontBg { destroy $w.fg } default { error "unknown -type $option(-type)" } } $w.t insert 0.0 $initialfont $w.t configure -state disabled set widgets(frame) ::textAttribSel::${w}::$w rename $w ::$widgets(frame) proc ::$w { command args } \ "eval ::textAttribSel::WidgetProc $w \$command \$args" return $w } # ::textAttribSel::WidgetProc -- # # This gets uses as the widgetproc for an textAttribSel widget. # Notice where the widget is created and you'll see that the # actual widget proc merely evals this proc with all of the # arguments intact. # # Arguments: # # w widget pathname # command widget subcommand # args additional arguments; varies with the subcommand # # Results: # # Performs the requested widget command proc ::textAttribSel::WidgetProc { w command args } { upvar ::textAttribSel::${w}::widgets widgets switch -- $command { cget { switch -- [lindex $args 0] { -font { return [string map {\n {}} \ [$widgets(text) get 0.0 end]] } -bg - -background { return [$widgets(text) cget -background] } -fg - -foreground { return [$widgets(text) cget -foreground] } } } } } # ::textAttribSel::ShowFontSel -- # # Callback function that is called when the font button is # pressed. # # Arguments: # # w widget pathname # variable assigned variable # # Results: # # Opens the font selection dialogue. proc textAttribSel::ShowFontSel { w variable } { upvar $variable font if { ![info exists font] } { set font "Helvetica 12" } set font [dkf_chooseFont -apply "wm title ." -initialfont $font] if { $font eq "" } { return } $w.t configure -state normal $w.t delete 0.0 end $w.t insert 0.0 $font {} $w.t configure -state disabled if { $variable ne "" } { set $variable $font } } # ::textAttribSel::ShowColorSel -- # # Callback function that is called when the foreground # or background button is pressed. # # Arguments: # # w widget pathname # variable assigned variable # # Results: # # Opens the color selection dialogue. proc textAttribSel::ShowColorSel { w type variable } { upvar color $variable if { ![info exists color] } { switch $type { fg { set color black } bg { set color white } } } set color [tk_chooseColor -initialcolor $color -parent $w] if { $color eq "" } { return } switch $type { fg { $w.t configure -foreground $color } bg { $w.t configure -background $color } } if { $variable ne "" } { set $variable $color } } # # some demo code # if { [info script] eq "$argv0" } { proc txtAttr {} { foreach item {.stdout .stderr .usr} { puts [$item cget -font] puts [$item cget -fg] puts [$item cget -bg] } } set fgimage [image create photo fg2 -data { R0lGODlhGAAYAMYDAAAAAHw4WbgkJDVSm7gnJrIrJ6cxJThUnDtXnqk1P3dW KUFcoEFcoYxGYb44OFFzLEhipE9lpMA/P05npzOMLzaNMlFqqbFNQlRtqoBg hYhhcJlhRT+TPEOVP7ZYTsBTV2Z5r8dZWMlaWk+cTFafUnGFuF+lXISYZoGT wISVwnOwcIeYw5SWunmzdqenp9uRkZqozceZpIy+iryhs4/AjdmbmLeovaOw 0ZbDlJzCltuintWwp6/NqrPPreq+vsbO4+3IyMvfyc/kztnp2ODk79zr29/t 3+Pv4uns9Ony6Ozv9fjr6+z07O/27/P0+fz8/fz9/P78/P///zVSmzVSmzVS mzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVS mzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVS mzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmzVSmyH+FUNyZWF0 ZWQgd2l0aCBUaGUgR0lNUAAh+QQBCgB/ACwAAAAAGAAYAAAH6YB/goOEhYaH iAOIhQCNjo+QAIgAUpWWUkoTJS9LlZKHlJZON08oAzYCQFBSn4ahlTAHPwMr Ig49Lawuu4yWPxMpIAMzAjojuQC7Lr1SRBYIMQMREiI5FEO6vISUShADLBIN GgQ1HSqeyr0YAwsfAjsGBTwURejag5QDAxkCISQKGzjIsJTsniAATxgMSCDg BAUaQa4RTLdNCpIAAi5QMNFEipFLBZdVjCJAwAMKOC5NNPgnlA8PFCowUWlP JD5LQjjkopnN5sFLSY7w7MkoktFGFA0pW8p0KaKmUJMWihp1kdWrWLNqNRQI ADs= }] set ST(line1,std-font) "Courier 12" set ST(line1,std-fg) yellow set ST(line1,std-bg) blue textAttribSel::textAttribSel .stdout -label "Standard" \ -fontvariable ::ST(line1,std-font) \ -fgvariable ::ST(line1,std-fg) \ -bgvariable ::ST(line1,std-bg) \ -fgimage $fgimage textAttribSel::textAttribSel .stderr -label "Error" -type fontFg textAttribSel::textAttribSel .usr -label "User" -type fontBg pack .stdout pack .stderr pack .usr pack [button .b1 -text "Text Attributes" -command [list txtAttr]] if { $tcl_platform(platform) eq "windows" } { console show } }