[NEM] - A little fun project to create a news/stock ticker widget, and here's the result. I used [Snit's Not Incr Tcl] to make it act like a real Tk widget, but it's pure Tk code apart from that. Basically, the widget is a single line display (like a label), which you can add messages to. The messages scroll across the widget one after the other in order. You can click on a message and a procedure will be run, so you could have the messages as articles from slashdot and the procedure would launch a browser to the appropriate page.

There are a couple of bugs with the implementation, but it's good enough for my purposes. The main bug is that if you resize the widget (making it smaller) then the items can screw up and become overlapped. You can workaround by deleting all items and then re-adding them on a resize, but a real fix would be better.

Anyway - the package (need's Tcl 8.4 as I use [lset]):

 # Defines a snit widget type for a ticker.
 
 package provide ticker 0.1 
 
 package require Tcl 8.4
 package require Tk
 package require snit
 
 snit::widget ticker {
    option -scrollstep      -2
    option -scrollinterval  20
    option -font            {Helvetica 12 bold}
 
    variable event          ""
    variable items          [list]
    variable newitems       [list]
    variable messagelength  0
 
    constructor {args} {
        component hull is [canvas $self]
        $self configurelist $args
        set height [font metrics $options(-font) -linespace]
        $self configure -height [expr {$height + 4}]
        $self resume
    }
 
    method dummy {args} {}
 
    method add {text command} {
        # Append a new item to the ticker, and register a callback on it
        set id [$self create text 2000 2 -anchor nw -text $text \
            -fill #efeb90 -font $options(-font)]
        $self bind $id <Enter> [list $self Enter $id]
        $self bind $id <Leave> [list $self Leave $id]
        $self bind $id <ButtonPress-1> [concat $command $id]
        set width [font measure $options(-font) $text]
        if {![llength $items]} {
            set insertpos [winfo width $self]
        }
        lappend newitems $id $width
        return $id
    }
 
    method remove {id} {
        $self delete $id
        if {$id eq "all"} {
            set items [list]
        } elseif {[set idx [lsearch $items $id]] != -1} {
            set width [lindex $items [expr {$idx + 1}]]
            set items [lreplace $items $idx [expr {$idx + 2}]]
            # We need to adjust the position of all items after this one:
            for {set i [expr {$idx + 2}]} {$i < [llength $items]} {incr i 3} {
                lset items $i [expr {[lindex $items $i] - ($width + 20)}]
            }
        }
        if {![llength $items]} {
            set messagelength 0
            $self stop
        }
    }
 
    method Enter {id} {
        $self itemconfigure $id -fill red
        $self stop
    }
 
    method Leave {id} {
        $self itemconfigure $id -fill #efeb90
        $self resume
    }
 
    method Scroll {} {
        # Moves all the items along, and keeps track of everything.
        set idx 0
        set flag 1
        set pos [winfo width $self]
        set width 0
        foreach {id width pos} $items {
            incr pos $options(-scrollstep)
            if {($pos + $messagelength) < 0} {
                set pos [winfo width $self]
                set flag 1
            } else {
                set flag 0
            }
            $self coords $id $pos 2
            lset items [expr {$idx + 2}] $pos
            incr idx 3
        }
        set insertpos [expr {$pos + $width + 20}]
        if {$flag && [llength $newitems]} {
            # We have just wrapped around the last item, so it is safe to
            # append new items now:
            foreach {item width} $newitems {
                lappend items $item $width $insertpos
                incr insertpos $width
                incr insertpos 20
                if {$width > $messagelength} {
                    set messagelength $width
                }
            }
            set newitems [list]
        }
        set event [after $options(-scrollinterval) [list $self Scroll]]
    }
 
    method stop {} {
        foreach id [after info] {
            after cancel $id
        }
    }
 
    method resume {} {
        set event [after $options(-scrollinterval) [list $self Scroll]]
    }
 
    delegate method * to hull
    delegate option * to hull
 
    destructor {
        # Nothing
    }
 }

The basic usage is:

 ticker .t
 set id [.t add <message> <procname>]
 .t add ....
     .
     .
 .t remove $id
 .t remove all

You can specify the amount of pixels each item should move per cycle (-scrollstep), the time interval between each cycle (-scrollinterval, in milliseconds), and the font to use for drawing the messages (-font). The widget is a wrapper round a canvas so you can also use all the canvas configuration options and commands. The ids returned from the ".t add" method are real canvas ids, so you can bind to them etc (note that the widget already defines some bindings on the ids).

A little demo:

 #!/bin/sh
 # Next line restarts with wish \
 exec wish "$0" ${1+"$@"}
 
 lappend auto_path .
 package require ticker 
 
 proc click {id} {
    puts "Pressed id $id"
 }
 
 proc popup {id} {
    tk_messageBox -icon info -title "Hello!" -message "Hi!"
 }
 
 ticker .t -bg navy -relief sunken
 
 . configure -relief raised -borderwidth 5
 pack [button .close -text "X" -font {Helvetica 12 bold} \
    -command {destroy .} -padx 0 -pady 0] \
        -side right -expand 0 -padx 0 -pady 0
 pack .t -fill x -expand 1
 
 wm withdraw .
 wm overrideredirect . 1
 wm geometry . [winfo screenwidth .]x30+0+0
 update idletasks
 wm deiconify .
 
 
 # Add some messages to the ticker
 .t add "This is a sample message to test that the ticker is working correctly" click
 .t add "Here is another message with a different handler" popup
 .t add "Hello Tcl'ers!" click

That's all folks! Could do with a bit more polish, but it's useable.
----
[Category Widget]