[ulis], 2003-09-28. [http://perso.wanadoo.fr/maurice.ulis/tcl/merge1.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/merge2.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/merge3.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/merge4.gif] [http://perso.wanadoo.fr/maurice.ulis/tcl/merge5.gif] ---- Please, download the images file before running the script: http://perso.wanadoo.fr/maurice.ulis/tcl/flower-1.gif http://perso.wanadoo.fr/maurice.ulis/tcl/flower-2.gif ---- # parameters of 1st image set file1 flower-1.gif # parameters of 2nd image set file2 flower-2.gif set dx 0 ;# x displacement set dy 0 ;# y displacement set alpha 0.25 ;# opacity if {$alpha < 0.0 || $alpha > 1.0} \ { error "alpha should be between 0.0 and 1.0" } # package package require Tk # merge proc proc merge {img1 img2 dx dy alpha} \ { set a2 $alpha set a1 [expr {1.0 - $a2}] set width1 [image width $img1] set height1 [image height $img1] set width2 [image width $img2] set height2 [image height $img2] set x1 $dx set x2 0 for {set i 0} {$i < $width1} {incr i} \ { if {$i > $width2} { break } set y1 $dy set y2 0 for {set j 0} {$j < $height1} {incr j} \ { if {$j > $height2} { break } if {![$img2 transparency get $x2 $y2]} \ { foreach {R G B} [$img1 get $x1 $y1] break foreach {_R _G _B} [$img2 get $x2 $y2] break foreach c {R G B} \ { set c2 [set _$c] set c1 [set $c] set $c [expr {round($c1 * $a1 + $c2 * $a2)}] } set color [format #%02x%02x%02x $R $G $B] $img1 put $color -to $x1 $y1 } incr y1 incr y2 } incr x1 incr x2 } } # create images image create photo _img1_ -file $file1 image create photo _img2_ -file $file2 # merge images merge _img1_ _img2_ $dx $dy $alpha # display result pack [canvas .c] .c create image 0 0 -anchor nw -image _img1_ ---- [Category Example]