Updated 2009-01-02 18:12:38 by jenglish

Bryan Oakley writes, on comp.lang.tcl, :
 Geoffrey King wrote:
 > Larry, you would be right. In a phrase i would like "simple MS Word"
 > style editing or "HTML editing" might be better. It would have : font
 > variations, tables, bullet points, inline images, nestings of the above.
 > Any more is a bonus. From the posts I suspect that meagre list will be
 > hard to find.

I'm pretty certain no megawidget exists that does that. However, it's honestly not that hard to write your own given what's built in to the text widget already. Tables and embedded images would be the only thing remotely hard (flowing around images, for example, can't be done). If you just want to be able to pick fonts, colors, text size and alignment, bullets, etc., that stuff is easy.

As a starting point, here's some code that shows one way to implement a bold and italic button. It's not complete, but it illustrates how to intercept text insertions and apply any tags that you want.

First, a simple megawidget (pure tcl, no megawidget package required!) that adds a new "tags" command to the text widget, and code to apply those tags to all newly inserted text (here's hoping line boundaries don't get screwed up as it passes through the ether!):
 package require Tcl 8.5

 namespace eval rtext {
   namespace eval instance {}

 proc rtext::rtext {path args} {
   upvar \#0 [namespace current]::data-$path data

   set data(tags) ""
   set data(actual) [namespace current]::instance::$path
   text $path
   rename $path $data(actual)
   interp alias \
       {} $path \
       {} [namespace which -command widgetProxy] $path
   eval $data(actual) configure $args
   return $path

 # this gets called instead of the actual widget
 # command. Mostly it passes things through to the
 # actual widget, but "insert" and a new "tags"
 # command are treated specially. You could use
 # the "wcb" package to accomplish the same thing.

 proc rtext::widgetProxy {path cmd args} {
   upvar \#0 [namespace current]::data-$path data

   if {$cmd eq "insert"} {
     # for each block of text being inserted, add the list of
     # current tags to the list of tags to be applied to the block
     set statement [list $data(actual) insert [lindex $args 0]]
     foreach {string tags} [lrange $args 1 end] {
       lappend statement $string [concat $tags $data(tags)]
     set result [uplevel $statement]

   } elseif {$cmd eq "tags"} {
     # usage: $path tags ?tag ?tag ...??
     # if tags are given, apply the tags to any new text that is
     # inserted
     if {[llength $args] > 0} {
       set data(tags) $args
     set result $data(tags)

   } else {
     set result [uplevel [concat [list $data(actual) $cmd] $args]]

   return $result


Next, here's a little test program that creates an instance of the widget along with two toolbar buttons for bold and italic so you see how you would tie toolbar buttons to the new widget. Expanding the above to do underline, overstrike, text alignment, etc should be fairly straight-forward. Just create tags for every attribute you want on the toolbar and lather, rinse, repeat.
 package require Tk

 global style

 frame .tb -borderwidth 2 -relief groove
 rtext::rtext .rtext \
   -wrap word \
   -yscrollcommand [list .vsb set]
 scrollbar .vsb -command [list .rtext yview]
 pack .tb -side top -fill x
 pack .vsb -side right -fill y
 pack .rtext -side bottom -fill both -expand true

 font create boldFont \
      -family Helvetica -weight bold
 font create italicFont \
     -family Helvetica -slant italic
 font create boldItalicFont \
     -family Helvetica -weight bold -slant italic
 font create normalFont \
     -family Helvetica

 checkbutton .tb.bold \
     -indicatoron false -text "B" -bd 1 \
     -command [list toggleStyles .rtext] \
     -variable style(bold) -font boldFont \
     -onvalue 1 -offvalue 0
 checkbutton .tb.italic \
     -indicatoron false -text "I" -bd 1 \
     -command [list toggleStyles .rtext] \
     -variable style(italic) -font italicFont \
     -onvalue 1 -offvalue 0 -font italicFont
 pack .tb.bold .tb.italic -side left

 set style(bold) 0
 set style(italic) 0

 .rtext tag configure normal -font normalFont
 .rtext tag configure italic -font italicFont
 .rtext tag configure bold -font boldFont
 .rtext tag configure boldItalic -font boldItalicFont

 .rtext tags "normal"

 proc ::toggleStyles {w} {
   global style
   set tags {}
   if {$style(bold)} {lappend tags bold}
   if {$style(italic)} {lappend tags italic}
   if {$style(bold) && $style(italic)} {lappend tags boldItalic}
   if {[llength $tags] == 0} {set tags [list "normal"]}
   eval \$w tags $tags

   # if there is a selection, apply the current styles to the selection
   set sel [$w tag ranges sel]
   if {[llength $sel] > 0} {
     foreach {start end} $sel {
       # this could be generalized, but it's good enough
       # for this example..
       $w tag remove bold $start $end
       $w tag remove italic $start $end
       $w tag remove boldItalic $start $end
       $w tag remove normal $start $end
       foreach tag $tags {
         $w tag add $tag $start $end


Bryan Oakley http://www.tclscripting.com

Category Widget