====== # 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 # # package require Tk package provide textAttribSel 0.1 ## 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} { 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 # coerce into an array set widgets(foo) foo 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 foreach {option varname} { -fontvariable initialfont -fgvariable initialfg -bgvariable initialbg} { unset $varname upvar $options($option) $varname } # 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 {{tooltip} in [package names]} { 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} \ "::textAttribSel::WidgetProc [list $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 $variable color 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 } } ====== <> Package]