[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. [WikiDbImage idraw.jpg] You can draw rectangles, ovals, and lines and place text at any canvas position (multiline is possible, just type 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 {%W delete withtag current} bind .c {canvas_save %W} set g(mode) move bind . {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 {} $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 \ {set g(id) [%W find withtag current]; set g(x) [%W canvasx %x]; set g(y) [%W canvasy %y]} bind $w {canvas_move %W [%W canvasx %x] [%W canvasy %y]} foreach event { } { $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 { 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 {canvas_draw %W [%W canvasx %x] [%W canvasy %y]} if {$type eq "line"} { bind $w {canvas_straighten %W} } foreach event { } {$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 {CanvasFocus %W [%W canvasx %x] [%W canvasy %y]} bind $c {CanvasPaste %W [%W canvasx %x] [%W canvasy %y]} bind $c <> {CanvasTextCopy %W; CanvasDelete %W} bind $c <> {CanvasTextCopy %W} bind $c <> {CanvasPaste %W} $c bind text {CanvasTextHit %W [%W canvasx %x] [%W canvasy %y]} $c bind text {CanvasTextDrag %W [%W canvasx %x] [%W canvasy %y]} $c bind text {CanvasDelete %W} $c bind text {CanvasDelChar %W} $c bind text {CanvasBackSpace %W} $c bind text {CanvasErase %W} $c bind text {CanvasInsert %W \n} $c bind text {CanvasInsert %W %A} $c bind text {CanvasMoveRight %W} $c bind text {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. --- [AK] Note also tklib's [diagram] package and dia application. <> Graphics | Arts and crafts of Tcl-Tk programming