''[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 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