# 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
}
}