# Draw filled rectangle and some text into canvas at position (x,y).
proc drawInfo { x y color } {
set size 10
set tx [expr $x + $size * 2]
.t.c create rectangle $x $y [expr $x + $size] [expr $y + $size] -fill $color
.t.c create text $tx $y -anchor nw -fill $color -text "$color box"
}
proc drawTestCanvas { imgVersion} {
if { [catch {toplevel .t -visual truecolor}] } {
toplevel .t
}
wm title .t "Canvas window"
wm geometry .t "+0+0"
canvas .t.c -bg gray -width 300 -height 220
pack .t.c
puts "Drawing text and rectangles into canvas .."
.t.c create rectangle 1 1 299 219 -outline black
.t.c create rectangle 3 3 297 217 -outline green -width 2
drawInfo 140 10 black
drawInfo 140 30 white
drawInfo 140 50 red
drawInfo 140 70 green
drawInfo 140 90 blue
drawInfo 140 110 cyan
drawInfo 140 130 magenta
drawInfo 140 150 yellow
.t.c create text 160 170 -anchor nw -fill black -text "Created with:"
.t.c create text 160 190 -anchor nw -fill black -text "Tcl [info patchlevel] and Img $imgVersion"
update
}
proc canvas2Photo { canvId } {
# The following line grabs the contents of the canvas canvId into photo image ph.
set retVal [catch {image create photo -format window -data $canvId} ph]
if { $retVal != 0 } {
puts "\n\tFATAL ERROR: Cannot create photo from canvas window"
exit 1
}
return $ph
}
set retVal [catch {package require Img} version]
if { $retVal } {
error "Trying to load package Img: $version"
}
if { $tcl_platform(platform) == "windows" } {
catch { console show }
}
wm geometry . "+320+0"
drawTestCanvas $version
set ph [canvas2Photo .t.c]
puts "Writing canvas as JPG image: test.jpg"
$ph write test.jpg -format JPEG
puts "Writing canvas as GIF image: test.gif"
$ph write test.gif -format GIF
puts "Writing canvas as PNG image: test.png"
$ph write test.png -format PNG
button .b -text "Quit" -command exit
pack .b
update
