[David Easton] ''2004-03-29'' Here is a procedure to resize a photo image to the requested dimensions. Use: resize where: is a source image is the requested horizontal size in pixels is the requested vertical size in pixels is an optional destination image (if not provided, a new image is created) It is based on the same principles as [Expanding an image] and [Shrinking an image], but is up to 10x faster. Linear interpolation is used for all horizontal resizing and for vertical expansion. However, I've cheated with shrinking an image vertically by using a combination of linear interpolation and row removal. This should really be corrected, but it meets my needs. This is nice to have and certainly way faster than previous pages mentioned. I shrunk a 720x430 image by a factor of 2 in about 11 seconds on a 600Mhz machine. On observation: when it checks for a integral reduction request if finds changes to use "zoom" but not chances to use "subsample". And, BTW, I don't understand calling [Expr] explicitly in this case when [if] is going to do it anyway. Thanks - [Roy Terry] 29-March-2004 [David Easton] ''2004-03-29'' Roy, you are correct about [Expr] not being necessary in an [if] statement and so I've updated the code below to remove it (I forgot that [if] did that). I haven't used subsample because it purely removes pixels and therefore gives an inferior image compared to using linear interpolation as below. ---- ################################################### # # Name: resize # # Decsription: Copies a source image to a destination # image and resizes it using linear interpolation # # Parameters: newx - Width of new image # newy - Height of new image # src - Source image # dest - Destination image (optional) # # Returns: destination image # ################################################### proc resize {src newx newy {dest ""} } { set mx [image width $src] set my [image height $src] if { "$dest" == ""} { set dest [image create photo] } $dest configure -width $newx -height $newy # Check if we can just zoom using -zoom option on copy if { $newx % $mx == 0 && $newy % $my == 0} { set ix [expr {$newx / $mx}] set iy [expr {$newy / $my}] $dest copy $src -zoom $ix $iy return $dest } set ny 0 set ytot $my for {set y 0} {$y < $my} {incr y} { # # Do horizontal resize # foreach {pr pg pb} [$src get 0 $y] {break} set row [list] set thisrow [list] set nx 0 set xtot $mx for {set x 1} {$x < $mx} {incr x} { # Add whole pixels as necessary while { $xtot <= $newx } { lappend row [format "#%02x%02x%02x" $pr $pg $pb] lappend thisrow $pr $pg $pb incr xtot $mx incr nx } # Now add mixed pixels foreach {r g b} [$src get $x $y] {break} # Calculate ratios to use set xtot [expr {$xtot - $newx}] set rn $xtot set rp [expr {$mx - $xtot}] # This section covers shrinking an image where # more than 1 source pixel may be required to # define the destination pixel set xr 0 set xg 0 set xb 0 while { $xtot > $newx } { incr xr $r incr xg $g incr xb $b set xtot [expr {$xtot - $newx}] incr x foreach {r g b} [$src get $x $y] {break} } # Work out the new pixel colours set tr [expr {int( ($rn*$r + $xr + $rp*$pr) / $mx)}] set tg [expr {int( ($rn*$g + $xg + $rp*$pg) / $mx)}] set tb [expr {int( ($rn*$b + $xb + $rp*$pb) / $mx)}] if {$tr > 255} {set tr 255} if {$tg > 255} {set tg 255} if {$tb > 255} {set tb 255} # Output the pixel lappend row [format "#%02x%02x%02x" $tr $tg $tb] lappend thisrow $tr $tg $tb incr xtot $mx incr nx set pr $r set pg $g set pb $b } # Finish off pixels on this row while { $nx < $newx } { lappend row [format "#%02x%02x%02x" $r $g $b] lappend thisrow $r $g $b incr nx } # # Do vertical resize # if {[info exists prevrow]} { set nrow [list] # Add whole lines as necessary while { $ytot <= $newy } { $dest put -to 0 $ny [list $prow] incr ytot $my incr ny } # Now add mixed line # Calculate ratios to use set ytot [expr {$ytot - $newy}] set rn $ytot set rp [expr {$my - $rn}] # This section covers shrinking an image # where a single pixel is made from more than # 2 others. Actually we cheat and just remove # a line of pixels which is not as good as it should be while { $ytot > $newy } { set ytot [expr {$ytot - $newy}] incr y continue } # Calculate new row foreach {pr pg pb} $prevrow {r g b} $thisrow { set tr [expr {int( ($rn*$r + $rp*$pr) / $my)}] set tg [expr {int( ($rn*$g + $rp*$pg) / $my)}] set tb [expr {int( ($rn*$b + $rp*$pb) / $my)}] lappend nrow [format "#%02x%02x%02x" $tr $tg $tb] } $dest put -to 0 $ny [list $nrow] incr ytot $my incr ny } set prevrow $thisrow set prow $row update idletasks } # Finish off last rows while { $ny < $newy } { $dest put -to 0 $ny [list $row] incr ny } update idletasks return $dest } ---- '''Example''' # Create and pack a canvas pack [canvas .c] -expand true -fill both # Create source and destination image set src [image create photo -file image.gif] set dest [image create photo] $dest blank set h [image height $src] incr h 5 .c create image 0 0 -anchor nw -image $src .c create image 0 $h -anchor nw -image $dest # Copy src image to destination image and resize to 400 300 resize $src 400 300 $dest ---- '''See also''' * [Expanding an image] * [Shrinking an image] ---- [Category Graphics] | [Category Image Processing] | [Category Example]