kroc 4 Jun 2003 - This proc will create an image from a canvas. Actually, it only handle few canvas objects: images, rectangles, lines and circles, but others might been supported later. The proc return image name.
proc Canvas2Image { canvas } { # Start with a blank new image: set largeur [$canvas cget -width] set hauteur [$canvas cget -height] image create photo capture -width $largeur -height $hauteur capture put #FFFFFF -to 0 0 $largeur $hauteur # Get each canvas objects: foreach objet [$canvas find all] { if {[lsearch [$canvas type $objet] image] >= 0} { # Images set coords [$canvas bbox $objet] set Xcap [expr {int([lindex $coords 0])}] set Ycap [expr {int([lindex $coords 1])}] set Xfin [expr {int([lindex $coords 2])}] set Yfin [expr {int([lindex $coords 3])}] # Image could be move outside the canvas, copy only visible part: if { $Xcap < 0} { set sX [expr {abs($Xcap)}] set Xcap 0 } else { set sX 0 } if { $Ycap < 0} { set sY [expr {abs($Ycap)}] set Ycap 0 } else { set sY 0 } if { $Xfin >= 0 && $Yfin >= 0 } { set nom [$canvas itemcget $objet -image] if { [string equal -nocase [image type $nom] photo] } { capture copy $nom -from $sX $sY -to $Xcap $Ycap $Xfin $Yfin } else { image delete $nom } } } if {[lsearch [$canvas type $objet] rectangle] >= 0} { # Rectangles set width [expr {[$canvas itemcget $objet -width]/2.0}] if {$width <= 0.5} { set width 0.5 } set coords [$canvas coords $objet] set capcoul [$canvas itemcget $objet -outline] set x1a [expr {round([lindex $coords 0]-$width)}] set x1b [expr {round([lindex $coords 0]+$width)}] set y1a [expr {round([lindex $coords 1]-$width)}] set y1b [expr {round([lindex $coords 1]+$width)}] set x2a [expr {round([lindex $coords 2]-$width)}] set x2b [expr {round([lindex $coords 2]+$width)}] set y2a [expr {round([lindex $coords 3]-$width)}] set y2b [expr {round([lindex $coords 3]+$width)}] # as it could be move outside the canvas, copy only visible part: if {$x1a < 0} { set x1a 0 } if {$x1b < 0} { set x1b 0 } if {$y1a < 0} { set y1a 0 } if {$y1b < 0} { set y1b 0 } if {$x2a < 0} { set x2a 0 } if {$x2b < 0} { set x2b 0 } if {$y2a < 0} { set y2a 0 } if {$y2b < 0} { set y2b 0 } capture put $capcoul -to $x1a $y1a $x1b $y2b capture put $capcoul -to $x2a $y1a $x2b $y2b capture put $capcoul -to $x1a $y1a $x2a $y1b capture put $capcoul -to $x1a $y2a $x2a $y2b } if {[lsearch [$canvas type $objet] line] >= 0} { # lines set width [expr {[$canvas itemcget $objet -width]}] if {$width <= 1.0} { set width 1.0 } set coords [$canvas coords $objet] set capcoul [$canvas itemcget $objet -fill] set x1 [expr {int([lindex $coords 0])}] set y1 [expr {int([lindex $coords 1])}] set x2 [expr {int([lindex $coords 2])}] set y2 [expr {int([lindex $coords 3])}] if { $x1==$x2 } { # as it could be move outside the canvas, copy only visible part: if {$x1 < 0} { set x1 0 } if {$x2 < 0} { set x2 0 } if {$y1 < 0} { set y1 0 } if {$y2 < 0} { set y2 0 } capture put $capcoul -to [expr {round($x1-($width/2.0))}] $y1 \ [expr {round($x2+($width/2.0))}] $y2 } elseif { $y1==$y2 } { # as it could be move outside the canvas, copy only visible part: if {$x1 < 0} { set x1 0 } if {$x2 < 0} { set x2 0 } if {$y1 < 0} { set y1 0 } if {$y2 < 0} { set y2 0 } capture put $capcoul -to $x1 [expr {round($y1-($width/2.0))}] $x2 \ [expr {round($y2+($width/2.0))}] } else { set m [expr {((1.0*$y2)-$y1)/($x2-$x1)}] set w1 [expr {$width/-2}] set w2 [expr {$width/2}] set beta [expr {2.0*atan(1.0)+atan($m)}] set step [expr abs(1.0/$m)] if {$step >= 0.5} { set step 0.5 } if {$x1 > $x2} { set x1 [expr {int([lindex $coords 2])}] set y1 [expr {int([lindex $coords 3])}] set x2 [expr {int([lindex $coords 0])}] set y2 [expr {int([lindex $coords 1])}] # as it could be move outside the canvas, copy only visible part: if {$x1 < 0} { set x1 0 } if {$x2 < 0} { set x2 0 } if {$y1 < 0} { set y1 0 } if {$y2 < 0} { set y2 0 } } for {set x $x1} {$x <= $x2} {set x [expr {$x+$step}]} { for { set dx $w1 } { $dx <= $w2 } {set dx [expr {$dx+$step}]} { set y [expr {$m*($x-$x1)+$y1}] set yt [expr {round($y+($dx*sin($beta)))}] set xt [expr {round($x+($dx*cos($beta)))}] if {$xt <= 0} { set xt 0 } if {$yt <= 0} { set yt 0 } capture put $capcoul -to $xt $yt } } } } if {[lsearch [$canvas type $objet] oval] >= 0} { # only circles set width [expr {[$canvas itemcget $objet -width]}] if {$width <= 1.0} { set width 1.0 } set 2pi [expr {8.0*atan(1)}] set coords [$canvas bbox $objet] set capcoul [$canvas itemcget $objet -outline] set a [expr {([lindex $coords 0]+[lindex $coords 2])/2.0}] set b [expr {([lindex $coords 1]+[lindex $coords 3])/2.0}] set rmax [expr {[lindex $coords 2]-$a}] set rmin [expr {$rmax-$width}] set step [expr {1.0/$rmax}] for {set R $rmin} {$R <= $rmax} {set R [expr {$R+0.4}]} { for {set alpha 0} {$alpha <= $2pi} {set alpha [expr {$alpha+$step}]} { set x [expr {$a+($R*cos($alpha))}] set y [expr {$b+($R*sin($alpha))}] if {$x <= 0} { set x 0 } if {$y <= 0} { set y 0 } capture put $capcoul -to [expr {round($x)}] [expr {round($y)}] } } } } return capture }
Here is a little script you could append to test it :
pack [canvas .c] .c create line 10 10 100 100 -width 12 -fill blue .c create line -10 10 80 100 -width 12 -fill red .c create line 10 -10 100 80 -width 12 -fill green .c create rectangle 125 15 223 212 -width 8 -outline yellow .c create oval 100 100 200 200 -width 4 -outline [tk_chooseColor] update Canvas2Image .c toplevel .i pack [canvas .i.c] .i.c create image 0 0 -image capture -anchor nw update
RS 2005-07-22: Alternatively, if you have the Img package,
pack [canvas .c] #-- ... add canvas items here ... wait for window to be visible ... set im [image create photo -data .c] $im write myname.gif -format GIF
is enough to dump a visible canvas's contents to a file :)
KPV 2006-04-13: To capture not just the visible part of a canvas but the whole canvas with Img check out Capturing Multiple Screens.
pi31415 2012-05-06: Alternatively, if you have ghostscript and TCL 8.6
# Set the GS_PROG environment variable first. # On Windows, you could use gswin32c.exe or gswin64c.exe package require Tcl 8.6 package require Tk namespace eval ::canvas2photo { set ghostscript undefined proc construct {} { if {[info exists ::env(GS_PROG)]} { set ::canvas2photo::ghostscript $::env(GS_PROG) } else { set ::canvas2photo::ghostscript "gs" } } proc convert {canvas} { set epsfile undefined set height [$canvas cget -height] set pngfile undefined set retval undefined set width [$canvas cget -width] # save canvas to an EPS file set epsfile [::canvas2photo::getTempFilename] $canvas postscript \ -colormode color \ -file $epsfile \ -height $height \ -pageanchor nw \ -pageheight $height \ -pagewidth $width \ -pagex 0 \ -pagey $height \ -width $width # convert EPS to PNG set pngfile [::canvas2photo::getTempFilename] exec $::canvas2photo::ghostscript \ -dBATCH \ -dDEVICEHEIGHTPOINTS=$height \ -dDEVICEWIDTHPOINTS=$width \ -dNOPAUSE \ -dSAFER \ -sDEVICE=pngalpha \ -sOutputFile=$pngfile \ $epsfile # load PNG to photo set retval [image create photo -file $pngfile -format png] # clean up file delete -force $epsfile file delete -force $pngfile return $retval } proc getTempFilename {} { set fh [file tempfile retval] close $fh return $retval } construct }