kroc 4 Jun 2003 - This proc will create a B&W 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 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 #000000 -to $x1a $y1a $x1b $y2b
capture put #000000 -to $x2a $y1a $x2b $y2b
capture put #000000 -to $x1a $y1a $x2a $y1b
capture put #000000 -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 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])}]
# 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 }
if { $x1==$x2 } {
capture put #000000 -to [expr {round($x1-($width/2.0))}] $y1 \
[expr {round($x2+($width/2.0))}] $y2
} elseif { $y1==$y2 } {
capture put #000000 -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])}]
}
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 #000000 -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 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 #000000 -to [expr {round($x)}] [expr {round($y)}]
}
}
}
}
return capture
}