Updated 2014-08-21 12:39:06 by FPX

Richard Suchenwirth 2004-03-29 - As I needed to produce a dataflow drawing, and did not want to bother with commercial drawing tools, I just hacked up the following thingy. Most of the code, regarding editable text items on the canvas, is borrowed from Brent Welch's book, and only slightly modified.

You can draw rectangles, ovals, and lines and place text at any canvas position (multiline is possible, just type <Return> for a new line), depending on the mode selected with the radiobuttons on top. In "move" mode, you can obviously move items around, until they look right. Right-click on an item (in any mode) to delete it. To save your drawing as a JPEG image, type Control-S. (GIF was rejected because of "too many colors"... I thought I only had black and white?)

Many more bells and whistles (selection of font family/style/size, line width, colors etc.) are conceivable, but the following code just did what I wanted, so here it is:
 package require Img

 proc main argv {
     global g
     set g(mode) ""
     trace var g(mode) w {changeMode .c}
     pack [radio .r g(mode) {move text line rect oval} -side left] -fill x
     pack [canvas .c -bg white] -fill both -expand 1
     bind .c <Button-3> {%W delete withtag current}
     bind .c <Control-s> {canvas_save %W}
     set g(mode) move

    bind . <Escape> {exec wish $argv0 &; exit}
 #-- A collection of radiobuttons:
 proc radio {w var values args} {
    frame $w
    set btns ""
    foreach value $values {
        lappend btns [radiobutton $w.b$value -indicatoron 0 \
                          -text $value -var $var -value $value] 
    eval pack $btns $args
    set w
 proc changeMode {w args} {
    bind $w <ButtonRelease-1> {}
    $w focus ""
    switch -- $::g(mode) {
        move {canvas_movable $w}
        text {Canvas_EditBind $w}
        line {canvas_drawable line $w}
        rect {canvas_drawable rect $w}
        oval {canvas_drawable oval $w}
 proc canvas_save w {
    set im [image create photo -format window -data $w]
    set filename [tk_getSaveFile -defaultextension .jpg \
                      -filetypes {{JPEG .jpg} {"All files" *}}]
    if {$filename ne ""} {
        $im write $filename -format JPEG
    image delete $im
 proc canvas_movable w {
    bind $w <Button-1> \
        {set g(id)  [%W find withtag current]; 
            set g(x) [%W canvasx %x]; 
            set g(y) [%W canvasy %y]}
    bind $w <B1-Motion> {canvas_move %W [%W canvasx %x] [%W canvasy %y]}
    foreach event {<Button-1> <B1-Motion>} {
        $w bind text $event {}
    $w config -cursor {}
 proc canvas_move {w xn yn} {
    global g
    $w move $g(id) [expr {$xn-$g(x)}] [expr {$yn-$g(y)}]
    set g(x) $xn
    set g(y) $yn
 proc canvas_drawable {type w} {
    global g
    set g(type) $type
    bind $w <Button-1> {
        set g(x) [%W canvasx %x]
        set g(y) [%W canvasy %y]
        set g(id) [%W create $g(type) $g(x) $g(y) $g(x) $g(y)]
    bind $w <B1-Motion> {canvas_draw %W [%W canvasx %x] [%W canvasy %y]}
    if {$type eq "line"} {
        bind $w <ButtonRelease-1> {canvas_straighten %W}
    foreach event {<Button-1> <B1-Motion>} {$w bind text $event {}}
    $w config -cursor lr_angle
 proc canvas_draw {w xn yn} {
    global g
    set coords [concat [lrange [$w coords $g(id)] 0 1] $xn $yn]
    $w coords $g(id) $coords
 proc canvas_straighten w {
    set id [$w find withtag current]
    foreach {x0 y0 x1 y1} [$w coords $id] break
    if {abs($x0-$x1)<4 && abs($y0-$y1)>10} {set x1 $x0}
    if {abs($y0-$y1)<4 && abs($x0-$x1)>10} {set y1 $y0}
    $w coords $id $x0 $y0 $x1 $y1

#-- Code from the Welch book
 proc Canvas_EditBind { c } {
    bind $c <Button-1> {CanvasFocus %W [%W canvasx %x] [%W canvasy %y]}
    bind $c <Button-2> {CanvasPaste %W [%W canvasx %x] [%W canvasy %y]}
    bind $c <<Cut>>    {CanvasTextCopy %W; CanvasDelete %W}
    bind $c <<Copy>>   {CanvasTextCopy %W}
    bind $c <<Paste>>  {CanvasPaste %W}
    $c bind text <Button-1>  {CanvasTextHit %W [%W canvasx %x] [%W canvasy %y]}
    $c bind text <B1-Motion> {CanvasTextDrag %W [%W canvasx %x] [%W canvasy %y]}
    $c bind text <Delete> {CanvasDelete %W}
    $c bind text <Control-d> {CanvasDelChar %W}
    $c bind text <BackSpace> {CanvasBackSpace %W}
    $c bind text <Control-Delete> {CanvasErase %W}
    $c bind text <Return> {CanvasInsert %W \n}
    $c bind text <Any-Key> {CanvasInsert %W %A}
    $c bind text <Key-Right> {CanvasMoveRight %W}
    $c bind text <Key-Left> {CanvasMoveLeft %W}
    $c config -cursor xterm

 proc CanvasFocus {c x y} {
    focus $c
    set id [$c find overlapping [expr $x-2] [expr $y-2] \
                [expr $x+2] [expr $y+2]]
    if {($id == {}) || ([$c type $id] != "text")} {
        set t [$c create text $x $y -text "" \
                   -tags text -anchor nw]
        $c focus $t
        $c select clear
        $c icursor $t 0
 proc CanvasTextHit {c x y {select 1}} {
     $c focus current
     $c icursor current @$x,$y
     $c select clear
     $c select from current @$x,$y
 proc CanvasTextDrag {c x y} {
     $c select to current @$x,$y
 proc CanvasDelete {c} {
     if {[$c select item] != {}} {
         $c dchars [$c select item] sel.first sel.last
     } elseif {[$c focus] != {}} {
         $c dchars [$c focus] insert
 proc CanvasTextCopy {c} {
     if {[$c select item] != {}} {
         clipboard clear
         set t [$c select item]
         set text [$c itemcget $t -text]
         set start [$c index $t sel.first]
         set end [$c index $t sel.last]
         clipboard append [string range $text $start $end]
     } elseif {[$c focus] != {}} {
         clipboard clear
         set t [$c focus]
         set text [$c itemcget $t -text]
         clipboard append $text
 proc CanvasDelChar {c} {
     if {[$c focus] ne {}} {
         $c dchars [$c focus] insert
 proc CanvasBackSpace {c} {
     if {[$c select item] != {}} {
         $c dchars [$c select item] sel.first sel.last
     } elseif {[$c focus] != {}} {
         set _t [$c focus]
         $c icursor $_t [expr {[$c index $_t insert]-1}]
         $c dchars $_t insert
 proc CanvasErase  {c}       {$c delete [$c focus]}

 proc CanvasInsert {c char}  {$c insert [$c focus] insert $char}

 proc CanvasPaste  {c {x {}} {y {}}} {
     if {[catch {selection get} _s] &&
         [catch {selection get -selection CLIPBOARD} _s]} {
         return         ;# No selection
     set id [$c focus]
     if {[string length $id] == 0 } {
         set id [$c find withtag current]
     if {[string length $id] == 0 } {
         # No object under the mouse
         if {[string length $x] == 0} {
             # Keyboard paste
             set x [expr {[winfo pointerx $c] - [winfo rootx $c]}]
             set y [expr {[winfo pointery $c] - [winfo rooty $c]}]
         CanvasFocus $c $x $y
     } else {
         $c focus $id
     $c insert [$c focus] insert $_s
 proc CanvasMoveRight {c} {
     $c icursor [$c focus] [expr [$c index current insert]+1]
 proc CanvasMoveLeft {c} {
     $c icursor [$c focus] [expr [$c index current insert]-1]

 main $argv

See also: A tiny drawing program

Ro 2012-04-08 removed a call to global that wasn't necessary and was breaking on 8.5

The saving proc is very instructive because it uses an undocumented ability of Img to save the contents of a window to jpeg.

FPX However, Img only copies the windows's visible area to the image. If the window is covered, e.g., by another application, the covered parts appear blank. (Observed on Windows.)


AK Note also tklib's diagram package and dia application.