This provides a new toplevel for arranging [preferences] or options in a common manner.

I still have some ideas for it. But right now it works fine. Some options can only be configured at creation time like -tabfont. It makes use of the [BLT] tabs but I tried to separate the tab functionality so that an other tab [widget] could be used. Any volunteers for tile ? [SC] No but I added [BWidget]s (see end of page).


''Mar. 05. 2006 Changes:''
   * added BWidget Tabstyle contributed by [SC]
   * use canvas to draw title of a page to show gradients [http://wiki.tcl.tk/9079]

''Oct. 19. 2005 Changes:''
   * fix typo in option
   * add color option for selected item
   * set default font to font size 10
   * leave selected item marked when highlighting another item
   * separate procs for enter and leave of an item

''Oct. 14. 2005 Changes:''
   * delete widgets array when widget is destroyed
   * add new command options
   * add _rcsid variable for version tracking


----

 # 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.
 #
 #
 # This widgets presents a framework for a
 # preferences widget.
 #
 # Requirements:
 #     BLT, BWidget             one of the two
 #     autoscroll               only used if package is installed
 #
 # Options:
 #    -canceltext <text>	text for Cancel Button
 #    -command <script>		script is invoked with 2
 #                               parameter, window and cmd
 #    -defaulttext <text>	text for Default Button
 #    -font
 #    -oktext <text>		text for Ok Button
 #    -relief <relief>
 #    -tabfont <font>
 #    -textbackground <color>
 #    -textforeground <color>
 #    -highlightbackground <color>
 #    -highlightforeground <color>
 #    -selectedbackground <color>
 #    -selectedforeground <color>
 #    -tabstyle <style>		blt or bwidget
 #    -type			okCancel, defaultOkCancel
 #
 # Commands:
 #       insert <index> <text> ?option value?
 #       configure ?option value?
 #       options                 returns a key value list of
 #                               index and the path to the frame
 #
 # Insert Options:
 #    -title <text>
 #    -titleimage <image>
 #    -titlefont <font>
 #    -titlefg color
 #    -titlebg {'gradient' ['x'|'y'] <color1> <color2>, 'solid' <color>}
 #
 # Thanks to Rohan Pall for his gradients example on the wiki 9079.
 #
 #
 
 package require msgcat
 
 msgcat::mcset de Ok		"  Ok  "
 msgcat::mcset de Cancel		"Cancel"
 msgcat::mcset de Default	"Standardwerte"
 
 namespace eval prefs {
     variable widgetOptions
     variable widgetCommands
 
     variable _rcsid "\$Id: 14831,v 1.16 2006-03-06 07:00:16 jcw Exp $"
 }
 
 # ::prefs::prefs --
 #
 #     This is the command that gets exported. It creates a new
 #     prefs 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 prefs::prefs { w args } {
 
     namespace export prefs
 
     variable widgetOptions
     variable widgetCommands
 
     if {![info exists widgetOptions]} {
 	Init
     }
 
     eval Build $w $args
 
 }
 
 # ::prefs::Init --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #     All state variables are set to their default values; all of
 #     the option database entries will exist.
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::Init {} {
     variable widgetOptions
     variable widgetCommands
 
     array set widgetOptions [list \
     	-canceltext		{cancelText	CancelText}	\
     	-command		{command	Command}	\
     	-defaulttext		{defaultText	DefaultText}	\
     	-font			{font		Font}		\
     	-oktext			{okText		OkText}		\
     	-relief			{relief		Relief}		\
     	-tabfont		{tabFont	TabFont}	\
     	-textbackground		{textBackground	TextBackground}	\
     	-textforeground		{textForeground	TextForeground}	\
     	-highlightbackground	{highlightBackground 	HighlightBackground}	\
     	-highlightforeground	{highlightForeground	HighlightForeground}	\
     	-selectedbackground	{selectedBackground	SelectedBackground}	\
     	-selectedforeground	{selectedForeground	SelectedForeground}	\
     	-tabstyle		{tabStyle	TabStyle}	\
     	-titlefont		{titleFont	TitleFont}	\
     	-titlefg		{titleForeground	TitleForeground}	\
     	-titlebg		{titleBackground	TitleBackground}	\
     	-type			{type		Type}		\
     ]
 
     set widgetCommands [list \
     	insert	configure options
     ]
 
     option add *Preferences.cancelText             " Cancel  "    widgetDefault
     option add *Preferences.defaultText            " Default "    widgetDefault
     option add *Preferences.okText                 "   Ok    "    widgetDefault
     option add *Preferences.font                   "Helvetica 10 bold" widgetDefault
     option add *Preferences.highlightBackground    darkblue       widgetDefault
     option add *Preferences.highlightForeground    white          widgetDefault
     option add *Preferences.selectedBackground     darkblue       widgetDefault
     option add *Preferences.selectedForeground     white          widgetDefault
     option add *Preferences.tabFont                "Helvetica 10" widgetDefault
     option add *Preferences.titleFont              "Helvetica 24" widgetDefault
     option add *Preferences.titleForeground        "black"        widgetDefault
     option add *Preferences.titleBackground        ""		  widgetDefault
     option add *Preferences.tabStyle               blt            widgetDefault
     option add *Preferences.textBackground         white          widgetDefault
     option add *Preferences.textForeground         black          widgetDefault
     option add *Preferences.type                   okCancel       widgetDefault
 
     # set class bindings
     SetClassBindings
 }
 
 # ::prefs::SetClassBindings --
 #
 #    Sets up the default bindings for the widget class
 #
 #    this proc exists since it's The Right Thing To Do, but
 #    I haven't had the time to figure out how to do all the
 #    binding stuff on a class level. The main problem is that
 #    the entry widget must have focus for the insertion cursor
 #    to be visible. So, I either have to have the entry widget
 #    have the Combobox bindtag, or do some fancy juggling of
 #    events or some such. What a pain.
 #
 # Arguments:
 #
 #    none
 #
 # Returns:
 #
 #    empty string
 
 proc ::prefs::SetClassBindings {} {
 
     # make sure we clean up after ourselves...
     bind Preferences <Destroy> [list ::prefs::DestroyHandler %W]
 
     return ""
 }
 
 # ::prefs::Build --
 #
 #    This does all of the work necessary to create the basic
 #    prefs.
 #
 # 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 ::prefs
 #
 # Returns:
 #
 #    the name of the widget
 
 proc prefs::Build { w args } {
     variable widgetOptions
 
     namespace eval ::prefs::$w {
 	variable widgets
 	variable options
 	variable data
 
 	set widgets(foo) foo  ;# coerce into an array
 	set options(foo) foo  ;# coerce into an array
 	set data(foo) foo  ;# coerce into an array
 
 	unset widgets(foo)
 	unset options(foo)
 	unset data(foo)
     }
 
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     # create GUI
     #
     #    +------------------------------------------+
     #    | +----------+  +------------------------+ |
     #    | |        |-|  |                        | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |optList | |  |    optFrame            | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |        | |  |                        | |
     #    | |        |-|  |                        | |
     #    | +----------+  +------------------------+ |
     #    |                                          |
     #    |   +----------+  +--------+  +--------+   |
     #    |   | Default  |  |   Ok   |  | Cancel |   |
     #    |   +----------+  +--------+  +--------+   |
     #    +------------------------------------------+
     #
 
     # create optList and optFrame
     set widgets(this)  [toplevel $w -class Preferences]
 
     # this defines all of the default options. We get the
     # values from the option database. Note that if an array
     # value is a list of length one it is an alias to another
     # option, so we just ignore it
     # if one option is given as argument use its value
     # instead of the default option
     foreach name [array names widgetOptions] {
 	if {[llength $widgetOptions($name)] == 1} continue
 	if { [lsearch $args $name] > -1 } {
 
 	    set idx [lsearch $args $name]
 	    set value [lindex $args [expr $idx + 1]]
 	    set options($name) $value
 	} else {
 
 	    set optName  [lindex $widgetOptions($name) 0]
 	    set optClass [lindex $widgetOptions($name) 1]
 
 	    set value [option get $w $optName $optClass]
 	    set options($name) $value
 	}
     }
 
     set pw $w.pw
     set widgets(optPanedWin) [panedwindow $pw -orient horizontal \
         -showhandle 0 -sashwidth 5]
 
     set f1 [frame $pw.f1 -takefocus 0]
     set widgets(optVScroll) $f1.optVS
     set widgets(optHScroll) $f1.optHS
 
     set widgets(optList) [text $f1.optList \
         -cursor left_ptr \
         -takefocus 0 \
         -width 12 \
         -height 15 \
         -wrap none \
     	-spacing1 3 \
     	-spacing3 3 \
         -xscroll [list $widgets(optHScroll) set]\
         -yscroll [list $widgets(optVScroll) set]]
 
     # see efftcl hierlist.tcl
     set tabsize [option get $w indent Indent]
     set tabsize [winfo pixels $w 10]
     set tabs "15"
     for {set i 1} {$i < 20} {incr i} {
         lappend tabs [expr $i*$tabsize+15]
     }
     $widgets(optList) configure -tabs $tabs
 
     set btags [bindtags $widgets(optList)]
     set i [lsearch $btags Text]
     if {$i >= 0} {
         set btags [lreplace $btags $i $i]
     }
     bindtags $widgets(optList) $btags
     ## end
 
     scrollbar $widgets(optVScroll) -orient vertical
     scrollbar $widgets(optHScroll) -orient horizontal
 
     if { [lsearch [package names] autoscroll] > -1} {
 	package require autoscroll
 
 	autoscroll::autoscroll $widgets(optVScroll)
 	autoscroll::autoscroll $widgets(optHScroll)
     }
 
     grid $widgets(optList) -row 0 -column 0 -sticky news
     grid $widgets(optVScroll) -row 0 -column 1 -sticky ns
     grid $widgets(optHScroll) -row 1 -column 0 -sticky ew
 
     grid rowconfigure    $f1 0 -weight 1
     grid columnconfigure $f1 0 -weight 1
 
     set widgets(optFrame) [frame $w.optFrame -takefocus 0]
 
     $pw add $f1 -sticky news
     $pw add $widgets(optFrame) -sticky news
 
     grid $pw -row 0 -column 0 -sticky news -padx 5 -pady 5
 
     # create buttonFrame
     set btnf [frame $w.f2 -takefocus 0]
     set widgets(defaultButton) [button $btnf.defBtn]
     set widgets(okButton) [button $btnf.okBtn]
     set widgets(cancelButton) [button $btnf.cancelBtn]
 
     grid $widgets(defaultButton) $widgets(okButton) $widgets(cancelButton) \
     	-row 0 -padx 5
 
     grid $btnf -row 1 -column 0 -pady 10
     grid rowconfigure $w 0 -weight 1
     grid columnconfigure $w 0 -weight 1
 
     set widgets(frame) ::prefs::${w}::$w
     rename $w ::$widgets(frame)
     proc ::$w { command args } \
 	"eval ::prefs::WidgetProc $w \$command \$args"
 
     set data(curopt) ""
     if {[catch "::prefs::Configure [list $widgets(this)] [array get options]" error]} {
 	catch {destroy $w}
 	error "internal error: $error"
     }
 
     return $w
 }
 
 # ::prefs::DestroyHandler {w} --
 #
 #    Cleans up after a combobox widget is destroyed
 #
 # Arguments:
 #
 #    w    widget pathname
 #
 # Results:
 #
 #    The namespace that was created for the widget is deleted,
 #    and the widget proc is removed.
 
 proc ::prefs::DestroyHandler {w} {
     upvar ::prefs::${w}::widgets widgets
 
     array unset widgets
 
     catch {
 	# if the widget actually being destroyed is of class Combobox,
 	# remove the namespace and associated proc.
 	if {[string compare [winfo class $w] "Preferences"] == 0} {
 	    # delete the namespace and the proc which represents
 	    # our widget
 	    namespace delete ::combobox::$w
 	    rename $w {}
 	}
     }
     return ""
 }
 
 # ::prefs::Configure --
 #
 #    Implements the "configure" widget subcommand
 #
 # Arguments:
 #
 #    w      widget pathname
 #    args   zero or more option/value pairs (or a single option)
 #
 # Results:
 #
 #    Performs typcial "configure" type requests on the widget
 
 proc ::prefs::Configure {w args} {
     variable widgetOptions
 
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
 
     if {[llength $args] == 0} {
 	# hmmm. User must be wanting all configuration information
 	# note that if the value of an array element is of length
 	# one it is an alias, which needs to be handled slightly
 	# differently
 	set results {}
 	foreach opt [lsort [array names widgetOptions]] {
 	    if {[llength $widgetOptions($opt)] == 1} {
 		set alias $widgetOptions($opt)
 		set optName $widgetOptions($alias)
 		lappend results [list $opt $optName]
 	    } else {
 		set optName  [lindex $widgetOptions($opt) 0]
 		set optClass [lindex $widgetOptions($opt) 1]
 		set default [option get $w $optName $optClass]
 		if {[info exists options($opt)]} {
 		    lappend results [list $opt $optName $optClass \
 			    $default $options($opt)]
 		} else {
 		    lappend results [list $opt $optName $optClass \
 			    $default ""]
 		}
 	    }
 	}
 
 	return $results
     }
 
     # one argument means we are looking for configuration
     # information on a single option
     if {[llength $args] == 1} {
 	# set opt [::combobox::Canonize $w option [lindex $args 0]]
 	set opt [lindex $args 0]
 
 	set optName  [lindex $widgetOptions($opt) 0]
 	set optClass [lindex $widgetOptions($opt) 1]
 	set default [option get $w $optName $optClass]
 	set results [list $opt $optName $optClass \
 		$default $options($opt)]
 	return $results
     }
 
     # if we have an odd number of values, bail.
     if {[expr {[llength $args]%2}] == 1} {
 	# hmmm. An odd number of elements in args
 	error "value for \"[lindex $args end]\" missing"
     }
 
     foreach option [array names options] {
 	set newValue $options($option)
 	if {[info exists options($option)]} {
 	    set oldValue $options($option)
 	}
 
 	set options($option) $newValue
 	switch -- $option {
     	    -canceltext {
 		 $widgets(cancelButton) configure -text $newValue
     	    }
     	    -command {
     	        if { $newValue eq {} } {
 		    continue
     	        }
     	        foreach btn [list default ok cancel] {
 		    $widgets(${btn}Button) configure -command [list $newValue $w $btn]
     	        }
 		 wm protocol $widgets(this) WM_DELETE_WINDOW [list $newValue $w cancel]
     	    }
     	    -defaulttext {
 		 $widgets(defaultButton) configure -text $newValue
     	    }
     	    -font {
 		$widgets(optList) configure -font $newValue
     	    	set options($option) $newValue
 	    }
 	    -highlightbackground {
 	    }
 	    -highlightforeground {
 	    }
     	    -oktext {
 		 $widgets(okButton) configure -text $newValue
     	    }
     	    -tabfont {
     	    }
     	    -textbackground {
 		$widgets(optList) configure -background $newValue
     	    }
     	    -textbackground {
 		$widgets(optList) configure -foreground $newValue
     	    }
     	    -titlefont {
     	    }
     	    -type {
 		switch -- $newValue {
 		    "okCancel" {
 			grid forget $widgets(defaultButton)
 		    }
 		    default {
 		    }
 		}
     	    }
     	}
     }
 }
 
 # ::prefs::WidgetProc --
 #
 #
 # Arguments:
 #
 #    w         widget pathname
 #    command   widget subcommand
 #    args      additional arguments; varies with the subcommand
 #
 # Results:
 #
 #    Performs the requested widget command
 
 proc ::prefs::WidgetProc {w command args} {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     #puts "[info level 0]"
 
     set _args $args
     set index [lindex $_args 0]
     set _args [lreplace $_args 0 0]
     set nodeText [lindex $_args 0]
     set _args [lreplace $_args 0 0]
 
     # if we have an odd number of values, bail.
     if {[expr {[llength $_args]%2}] == 1} {
 	# hmmm. An odd number of elements in args
 	error "value for \"[lindex $args end]\" missing"
     }
 
     # Great. An even number of options. Let's make sure they
     # are all valid before we do anything. Note that Canonize
     # will generate an error if it finds a bogus option; otherwise
     # it returns the canonical option name
     foreach {name value} $_args {
 	set opts($name) $value
     }
 
     switch $command {
 	insert {
 	    set ident [string map {{ } {} {.} {}} $nodeText]
 	    set idx [string map {{ } {} {.} {}} $index]
 
 	    # for index "end" create a new frame
 	    # for a created index check if a tab widget exists
 	    #   if not create tab widget
 	    #   create a new frame
 	    switch -- $idx {
 		"end" {
 		    # create entry in optList widget
 		    if { [array get opts "-image"] ne "" } {
 			$widgets(optList) image create end \
 			    -image $opts(-image) -align center
 		    }
 		    $widgets(optList) insert end "$nodeText\n" [list optname $ident]
 
 		    $widgets(optList) tag bind $ident <Enter> \
 			[list ::prefs::EnterOption $w $ident]
 		    $widgets(optList) tag bind $ident <Leave> \
 			[list ::prefs::LeaveOption $w $ident]
 		    $widgets(optList) tag bind $ident <ButtonPress-1> \
 			[list ::prefs::ActivateOption $w $ident]
 
 		    set activebg $options(-selectedbackground)
 		    set activefg $options(-selectedforeground)
 		    $widgets(optList) tag configure selected -background $activebg -foreground $activefg
 
 		    eval ::prefs::addNewOption $w $args
 
 		    if { $data(curopt) eq "" } {
 			::prefs::ActivateOption $w $ident
 		    }
 
 		    set widgets(optFrame,${ident}Body) $widgets(optFrame,$ident).body
 		    frame $widgets(optFrame,${ident}Body) -takefocus 0
 		    pack $widgets(optFrame,${ident}Body) \
 		    	-expand 1 -fill both -side top -anchor nw
 
 		    return $widgets(optFrame,${ident}Body)
 		}
 		default {
 		    switch -- $options(-tabstyle) {
 			"blt" {
 			    set w [eval ::prefs::addNewBltTab $w $args]
 			}
 			"bwidget" {
 			    set w [eval ::prefs::addNewBwidgetTab $w $args]
 			}
 			default {
 			    error "only BLT tabs supported"
 			}
 		    }
 		    return $w
 		}
 	    }
 	}
 	options {
  	    set result [list]
  	    set name ""
  	    foreach item [array names widgets optFrame,*Body] {
 		regexp {optFrame,(.*)Body} $item dummy name
 		lappend result $name $widgets($item)
  	    }
  	    return $result
 	}
     }
 
 }
 
 # ::prefs::addNewOption --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   Insert new option in List
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::addNewOption { w args } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     # puts [info level 0]
     set index [lindex $args 0]
     set args [lreplace $args 0 0]
     set nodeText [lindex $args 0]
     set args [lreplace $args 0 0]
 
     # if we have an odd number of values, bail.
     if {[expr {[llength $args]%2}] == 1} {
 	# hmmm. An odd number of elements in args
 	error "value for \"[lindex $args end]\" missing"
     }
 
     # set default value
     set opts(-titlefont) $options(-titlefont) 
     set opts(-titlefg) $options(-titlefg) 
 
     # Great. An even number of options. Let's make sure they
     # are all valid before we do anything. Note that Canonize
     # will generate an error if it finds a bogus option; otherwise
     # it returns the canonical option name
     foreach {name value} $args {
 	set opts($name) $value
     }
 
     set ident [string map {{ } {} {.} {}} $nodeText]
     set idx [string map {{ } {} {.} {}} $index]
 
     set widgets(optFrame,$ident) $widgets(optFrame).opt-$ident
     frame $widgets(optFrame,$ident) -takefocus 0
 
     set drawSeparator 0
 
     set widgets(optFrame,${ident}Title) \
 	$widgets(optFrame,$ident).title
     frame $widgets(optFrame,${ident}Title) -takefocus 0
     set c $widgets(optFrame,${ident}Title).c1
 
     if { [array get opts "-title"] ne "" } {
 	# create title label
 
 	set xoffs 3
 	set yoffs 3
 	set ls [font metrics $opts(-titlefont) -linespace]
 	canvas $c -height [expr $ls + $yoffs] -relief flat \
 	    -borderwidth 0 -takefocus 0 \
 	     -background [. cget -bg] \
 	     -insertborderwidth 0 \
 	     -selectborderwidth 0 \
 	     -selectbackground  [. cget -bg] 
 	$c create text $xoffs $yoffs -tags title \
 	    -text $opts(-title) \
 	    -justify left -anchor nw \
 	    -font $opts(-titlefont) \
 	    -fill $opts(-titlefg)
 	set drawSeparator 1
     }
     if { [array get opts "-titlebg"] ne "" } {
 	set type [lindex $opts(-titlebg) 0]
 	switch $type {
 	    gradient {
 		set direction  [lindex $opts(-titlebg) 1]
 		set color1 [lindex $opts(-titlebg) 2]
 		set color2 [lindex $opts(-titlebg) 3]
 		bind $c <Configure> \
 		    [list ::prefs::gradient %W $direction $color1 $color2]
 	    }
 	    solid {
 		set color [lindex $opts(-titlebg) 1]
 		bind $c <Configure> \
 		    [list ::prefs::solid %W $color]
 
 	    }
 	    default {
 
 	    }
 	}
 
     }
     if { [array get opts "-titleimage"] ne "" } {
 	# add image
 	set xoffs 3
 	set yoffs 3
 	set ls [font metrics $opts(-titlefont) -linespace]
 
 	# if label doesn't exist yet create one
 	if { [array get opts "-title"] eq "" } {
 	    canvas $c -height [expr $ls + $yoffs] -takefocus 0
 
 	    set drawSeparator 1
 	} else {
 	    set xoffs [expr 3 + [image width $opts(-titleimage)]]
 	    set yoffs 3
 	    set ls [font metrics $options(-titlefont) -linespace]
 	    set ih [image height $opts(-titleimage)] 
 
 	    $c move title $xoffs 0
 	    if { $ls < $ih } {
 		$c configure -height [expr {$ih + $yoffs}]
 	    } else {
 		set as [font metrics $options(-titlefont) -ascent]
 		set yoffs [expr {$ls - $as}]
 	    }
 
 	}
 	$widgets(optFrame,${ident}Title).c1 create image \
 	    3 $yoffs -image $opts(-titleimage) -anchor nw
     }
 
     if { $drawSeparator == 1 } {
 	pack $widgets(optFrame,${ident}Title).c1 \
 	    -anchor nw -fill x
 	pack $widgets(optFrame,${ident}Title) \
 	    -anchor nw -fill x
 
 	frame $widgets(optFrame,${ident}Title).sep -height 2 \
 	    -relief sunken -takefocus 0 -borderwidth 2
 	pack $widgets(optFrame,${ident}Title).sep -fill x -pady 3
     }
 
 }
 
 # ::prefs::addNewBltTab --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   Add Suboption as BLT Tab
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::addNewBltTab { w args } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     if { [lsearch [package names] BLT] < 0 } {
 	error "package BLT is required"
     }
     package require BLT
 
     #puts [info level 0]
     set index [lindex $args 0]
     set args [lreplace $args 0 0]
     set nodeText [lindex $args 0]
     set args [lreplace $args 0 0]
 
     # if we have an odd number of values, bail.
     if {[expr {[llength $args]%2}] == 1} {
 	# hmmm. An odd number of elements in args
 	error "value for \"[lindex $args end]\" missing"
     }
 
     # Great. An even number of options. Let's make sure they
     # are all valid before we do anything. Note that Canonize
     # will generate an error if it finds a bogus option; otherwise
     # it returns the canonical option name
     foreach {name value} $args {
 	set opts($name) $value
     }
 
     set ident [string map {{ } {} {.} {}} $nodeText]
     set idx [string map {{ } {} {.} {}} $index]
 
     if {[lsearch [array names widgets] "optFrame,$idx"] > -1 } {
 	if {[lsearch [array names widgets] "optFrame,${idx}-tab"] < 0 } {
 	    # tab does not yet exist, create one
 	    set widgets(optFrame,${idx}-tab) $widgets(optFrame,${idx}Body).tab$idx
 
 	    set bgcolor [$widgets(this).pw cget -background]
 	    blt::tabset $widgets(optFrame,${idx}-tab) -relief flat \
 	        -takefocus 0 -tearoff 0 -tile "" \
 	        -font $options(-tabfont) \
 	        -borderwidth 0 \
 	        -background $bgcolor \
 	        -activebackground $bgcolor \
 	        -selectbackground $bgcolor \
 	        -tiers 3
 
 	    pack $widgets(optFrame,${idx}-tab) -expand 1 -fill both
 	}
 	set widgets(optFrame,$ident) $widgets(optFrame,${idx}-tab).$ident
 	frame $widgets(optFrame,$ident) -takefocus 0
 	$widgets(optFrame,${idx}-tab) insert end $opts(-title) \
 	    -window $widgets(optFrame,$ident) -fill both
 
 	return $widgets(optFrame,$ident)
 
     } else {
 	error "Unknown index $ident"
     }
 }
 
 # ::prefs::EnterOption --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   highlight item
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::EnterOption { w opt } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     $widgets(optList) tag configure $opt \
     	-background $options(-highlightbackground) \
     	-foreground $options(-highlightforeground)
 }
 
 # ::prefs::LeaveOption --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   remove highlight from item
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::LeaveOption { w opt } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     $widgets(optList) tag configure $opt -background {} -foreground {}
 }
 
 # ::prefs::ActivateOption --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   Show new frame and update internal variables
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::ActivateOption { w opt } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     if { $data(curopt) eq "" } {
 	set data(curopt) $opt
     }
 
     set range [$widgets(optList) tag ranges $data(curopt)]
     set start [lindex $range 0]
     set end [lindex $range 1]
     $widgets(optList) tag remove selected $start $end
 
     pack forget $widgets(optFrame,$data(curopt))
     pack $widgets(optFrame,$opt) -expand 1 -fill both -side top
 
     set data(curopt) $opt
     set range [$widgets(optList) tag ranges $data(curopt)]
     set start [lindex $range 0]
     set end [lindex $range 1]
     $widgets(optList) tag add selected $start $end
     $widgets(optList) tag raise selected
 
     pack $widgets(optFrame,$data(curopt)) -expand 1 -fill both \
     	-padx 5 -pady 5
 
 }
 
 # ::prefs::addNewBwidgetTab --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   Add Suboption as Bwidget Tab
 #
 # Returns:
 #
 #     empty string
 
 proc ::prefs::addNewBwidgetTab { w args } {
     upvar ::prefs::${w}::widgets widgets
     upvar ::prefs::${w}::options options
     upvar ::prefs::${w}::data data
 
     package require BWidget
 
     #puts [info level 0]
     set index [lindex $args 0]
     set args [lreplace $args 0 0]
     set nodeText [lindex $args 0]
     set args [lreplace $args 0 0]
 
     # if we have an odd number of values, bail.
     if {[expr {[llength $args]%2}] == 1} {
 	# hmmm. An odd number of elements in args
 	error "value for \"[lindex $args end]\" missing"
     }
 
     # Great. An even number of options. Let's make sure they
     # are all valid before we do anything. Note that Canonize
     # will generate an error if it finds a bogus option; otherwise
     # it returns the canonical option name
     foreach {name value} $args {
 	set opts($name) $value
     }
 
     set ident [string map {{ } {} {.} {}} $nodeText]
     set idx [string map {{ } {} {.} {}} $index]
 
     if {[lsearch [array names widgets] "optFrame,$idx"] > -1 } {
 	if {[lsearch [array names widgets] "optFrame,${idx}-tab"] < 0 } {
 	    # tab does not yet exist, create one
 
 	    set widgets(optFrame,${idx}-tab) $widgets(optFrame,${idx}Body).tab$idx
 
 	    set bgcolor [$widgets(this).pw cget -background]
 
 	    NoteBook $widgets(optFrame,${idx}-tab) \
 		-font $options(-tabfont) \
 		-activebackground $bgcolor \
 		-activeforeground blue
 
 	    pack $widgets(optFrame,${idx}-tab) -expand 1 -fill both
 	}
 
 	# do the insert of the new page, return the name of the new frame
 	# created
 	set widgets(optFrame,$ident)\
 	    [$widgets(optFrame,${idx}-tab) insert end $opts(-title)\
 	    -text $opts(-title)]
 
 	return $widgets(optFrame,$ident)
 
     } else {
 	error "Unknown index $ident"
     }
 }
 
 
 
 # ::prefs::rgbs --
 #
 # calculate colors for a gradient
 #
 # This procedure was taken from the wiki.tcl.tk
 # entry 9079.
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   
 #
 # Returns:
 #
 #     list of rgb values per step
 
 proc prefs::rgbs {n c1 c2} {
 
     # Color intensities are from 0 to 65535, 2 byte colors.
     foreach {r1 g1 b1} [winfo rgb . $c1] break
     foreach {r2 g2 b2} [winfo rgb . $c2] break
 
     # Normalize intensities to 0 to 255, 1 byte colors.
     foreach el {r1 g1 b1 r2 g2 b2} {
 	set $el [expr {[set $el] * 255 / 65535}].0
     }
 
     if {$n == 1} {
 	set r_step 0.0 
 	set g_step 0.0
 	set b_step 0.0
     } else {
 	set r_step [expr {($r2-$r1) / ($n-1)}]
 	set g_step [expr {($g2-$g1) / ($n-1)}]
 	set b_step [expr {($b2-$b1) / ($n-1)}]
 
 	set steps {}
 	for {set i 0} {$i < $n} {incr i} {
 	    set r [expr {int($r_step * $i + $r1)}]
 	    set g [expr {int($g_step * $i + $g1)}]
 	    set b [expr {int($b_step * $i + $b1)}]
 	    lappend steps [format "#%.2X%.2X%.2X" $r $g $b]
 	}
     }
 
     return $steps
 }
 
 # ::prefs::gradient --
 #
 # This procedure was taken from the wiki.tcl.tk
 # entry 9079.
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   
 #
 # Returns:
 #
 #     list of rgb values per step
 
 proc prefs::gradient { w {type x} {c1 darkgray} {c2 #d4d0c8}} {
 
     $w delete gradient
     set width [winfo width $w]
     set height [winfo height $w]
     if {[string equal $type "x"]} {
 	set n $width
 	set steps [rgbs $n $c1 $c2]
 	for {set i 0} {$i < $n} {incr i} {
 	    $w create line $i 0 $i $height -tags gradient -fill [lindex $steps $i]
 	}
     } else {
 	set n $height
 	set steps [rgbs $n $c1 $c2]
 	for {set i 0} {$i < $n} {incr i} {
 	    $w create line 0 $i $width $i -tags gradient -fill [lindex $steps $i]
 	}
     }
     $w lower gradient
 
 }
 
 # ::prefs::solid --
 #
 #
 # Arguments:
 #
 #    none
 #
 # Results:
 #
 #   
 #
 # Returns:
 #
 #     
 
 proc prefs::solid { w {color darkgray}} {
 
     $w delete solid
     set width [winfo width $w]
     set height [winfo height $w]
     $w create rectangle 0 0 $width $height \
         -fill $color -tags solid
     $w lower solid
 }
 
 
 ##
 # some demo code
 ##
 
 proc prefsAction { w cmd } {
     puts [info level 0]
 
     destroy $w
     exit
 }
 
 prefs::prefs .p1 \
     -textbackground white \
     -command prefsAction \
     -highlightbackground peru \
     -highlightforeground gold \
     -selectedbackground bisque4 \
     -tabstyle blt
 
 image create photo fonts -data {
 R0lGODlhHgAeAMYAAAAAAAICAgQEBAoKCgsLCw0NDQ8PDxUVFSIiIiMjIzAw
 MDU1NS9UjDBVjDNYjjRYjjRYjzpdkjxfk19fX2NjY2RkZGhoaFRzoFh2o1l2
 o3Nzc1x5pUqYPUyZQGB8p06aQVOdR2eCq4GBgV+kU3iQtI6OjoSau4Wbu3mz
 b4mevp6gooi7f6ioqK+vr6OzzKm4zq270a680rG/1LnG2MrKyszMzM7OzsrU
 4tHZ5djY2NXc59Pm0N/f3+Hh4ePj49rq2Orq6ufr8e7u7u/v7/L0+PT2+fz8
 /P7+/v///wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAEKAH8A
 LAAAAAAeAB4AAAf+gH+Cg4SFhoeIiYqLjI2Oj4cMDJCMkjKUiZIMHpiIDBcZ
 DDqdhZIwLgwpjBwcigwORX8PEkSLrEiZJLgQDDG2HLiRDDfBDBu/wYaayww4
 irfCzJInz8DCQUjZSEENESoA4ACF0MohweAlIQwvBOAUyX/khJIzuOFAJgwY
 Fe7w8oTZBIUbIghJjX6E/hkKB4CgQISDFBZi6PBPuHcJrSWiOOiivw/wDg3s
 CFEQhxEhDR0A14MkAIwmOaxIaSgBgAoPEbLi0OEHTUMiFAgIMCBcBVwcQKDY
 8XNiQSQ5wmkIpq0ROAOEwrVoqgiAABY5FxghNQEBwwIWhHBl5MMGDR4FRwIy
 CgQAOw==
 }
 
 image create photo hwfilter -data {
 R0lGODlhGgAaAKEAAAAAAP8AAP///wAAACH+FUNyZWF0ZWQgd2l0aCBUaGUg
 R0lNUAAsAAAAABoAGgAAAl6Eb4Ko6/yAErRGGWeltzm9dZm0ed9Ymot6gNb4
 sElK12EMX2uut3yPwQF9wmHwZDzukjIlwwZN/YiPgPWKuWJdHIDWmv1ipF6x
 4hsYlwzosFZ9a5/NpDhdXn8Vl44CADs=
 }
 
 # gradient  {x|y|d|c} opts
 #   x,y : color1 color2 [step offset]
 #   d(iagonal)   : color1 color2 [step offset degree]
 #   c(ircle)   : color1 color2 [step offset center]
 # solid color
 set fillOpts [list gradient x "#505050" [. cget -bg]]
 set t0 [.p1 insert end General -title "General" \
 	-titlebg $fillOpts -titlefg white]
 set t1 [.p1 insert end "Fonts and Colors" -title "Fonts and Colors" \
 	-titlebg $fillOpts -titlefg white -titleimage fonts]
 set fillOpts [list gradient x "SeaGreen4" [. cget -bg]]
 set t2 [.p1 insert end CANopen -title "CANopen" \
 	-titlebg $fillOpts -titlefg white]
 set fillOpts [list gradient x "MediumPurple4" [. cget -bg]]
 set t3 [.p1 insert end DeviceNet -title "DeviceNet" \
 	-titlebg $fillOpts -titlefg white ]
 set fillOpts [list gradient x "pink4" [. cget -bg]]
 set t4 [.p1 insert end J1939 -title "J1939" \
 	-titlebg $fillOpts -titlefg white]
 set t5 [.p1 insert CANopen pdomap -title "PDO Mapping"]
 set t6 [.p1 insert CANopen nodes -title "Node Names"]
 set t7 [.p1 insert CANopen fonts -title "Fonts and Colors"]
 set t8 [.p1 insert end X -title "Hardware Filter" \
 	-titleimage hwfilter \
 	-titlefg white \
 	-titlebg [list gradient x "#505050" [. cget -bg]]]
 
 foreach tab [list $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7 $t8] {
     puts $tab
     label $tab.l1 -text $tab
     pack $tab.l1 -side top
 }
  





----
[Category Widget]