Beefy Boxes and Bandwidth Generously Provided by pair Networks
go ahead... be a heretic
 
PerlMonks  

Tk image resizer

by Discipulus (Curate)
on May 05, 2014 at 11:08 UTC ( #1085037=CUFP: print w/ replies, xml ) Need Help??

Hello monks,

was a rainy saturday and i need some resized images for a new website (a Dancer2 one).. but i'm digressing.
This script globs all jpg images in the current directory and creates one or more resized ones with new names. EXIF data are cleaned in new images whilst you can view some of them, for your convenience, in the preview of the original image.

Only argouments accepted are string in the form width x heigth x descr as in 1204x768xBig
You can specify more then one format passing, for example: 1204x768xBig 640x480xMed 200x100xMin
The description in the string is optional: if not present is used the given ratio: 1204x768 wil be appended to the file name given.

Using Image::Resize the ratio is maintained for the original photo, ie only the width will be used, while the height will be adjusted as needed.

The code is redundant and somehow ugly, but Perl does not complains about this..

HtH
L*

#!/usr/bin/perl use warnings; use strict; use MIME::Base64; use Image::Resize; use Tk; use Tk::JPEG; use Image::EXIF; die "usage: $0 250x169xmin 768x250xmed\n \tEg Width x High x Descr. Third element can be omitted (the description) and Width x High string will be used.\n\n" unless (defined $ARGV[0] and $ +ARGV[0] =~ /\d+x\d+/); my @files = glob('*.jpg'); print "\nFound ".scalar @files." files\n\n"; exit if scalar @files == 0; my @size_descr = map { [split 'x', $_] }@ARGV; my $x = 640; my $y = 480; my $mx = $x; my $my = $y + 200; my $mw = new MainWindow (); $mw -> geometry ($mx.'x'.$my); $mw->optionAdd('*font', 'Courier 12'); my $c = $mw->Canvas; $c->pack(-expand => 1, -fill => 'both'); my $cur_file = shift @files; print "Considering $cur_file\n"; my $exif = &get_exif($cur_file); my $gd = &phres($cur_file,$x,$y); my $image = $c->Photo( -data=> MIME::Base64::encode( $gd )); $c->createImage($x/2 , $y/2, -image => $image); my $label_exif_txt = "Exif info\n". "size: ".($$exif{width} ? $$exif{width} : 'undef' + ). " x ".( $$exif{height} ? $$exif{height} :'undef' +)."\n". "date: ". ($$exif{date} ? $$exif{date} : 'undef') +; my $label_exif =$mw->Label( -justify => 'left', -background => 'black +',-foreground => 'chartreuse1', -textvariable => \$label_exif_txt )->pack; my $label =$mw->Label(-text=> 'Insert a new name for the photo above.' +."\n". 'The name will be added with the infix specified + in command line'."\n". 'Then hit <Return> or the button below.')->pack( +) ; my $button_skip = $mw->Button(-borderwidth => 2,-relief => 'solid',-te +xt => 'Skip this image', -command => \&next_pic)->pack; my $newname; my $entry = $mw->Entry( -width => 100,-borderwidth => 4, -textvariable + => \$newname)->pack; $entry->bind('<Return>' => \&elaborate); $entry->focus; my $button = $mw->Button(-borderwidth => 2,-relief => 'solid',-text => + 'Create resized and renamed images', -command => \&elaborate)->pack; $mw->MainLoop; ###################################################################### +########## sub next_pic { $cur_file = shift @files; unless ($cur_file){ print "\nThe End\n"; $c->destroy; $label->destroy; $label_exif->destroy; $button_skip->destroy; $entry->destroy; $button->destroy; $mw->Label(-text=>"The End\nwill happen in 3 seconds..")->pack +() ; $mw->update; sleep 3; exit 0; } print "Considering $cur_file\n"; $gd = &phres($cur_file,$x,$y); my $enc = MIME::Base64::encode($gd); $image->blank; $image= $c->Photo( -data=>$enc); $c->createImage($x/2 , $y/2,-image => $image ); $exif = &get_exif($cur_file); $label_exif_txt = "Exif info\n". "size: ".($$exif{width} ? $$exif{width} : +'undef' ). " x ".( $$exif{height} ? $$exif{height} :' +undef' )."\n". "date: ". ($$exif{date} ? $$exif{date} : ' +undef'); $entry->delete(0, 'end'); $mw->update; select(undef, undef, undef, .1); } ###################################################################### +########## sub elaborate{ $newname = $entry->get(); ######################################### foreach my $res ( @size_descr ) { my $gd = &phres($cur_file,$$res[0], $$res[1]); &write_resized ($newname."_".(defined $$res[2] ? $$res[2] +: "$$res[0]x$$res[1]" )."_".'.jpg',$gd); } ######################################### &next_pic; } ###################################################################### +########## sub phres { my ($file, $x, $y) = @_; my $image_orig = Image::Resize->new($file, $x, $y); my $gd = $image_orig->resize($x, $y); return $gd->jpeg(); } ###################################################################### +########## sub write_resized{ my ($name, $data) = @_; open(FH, '>', $name) or warn "Cannot write to $name! "; binmode FH; print FH $data; close(FH); print "\tOK: wrote $name\n"; } ###################################################################### +########## sub get_exif { my $file = shift; my $exif = Image::EXIF->new($file); my %exif_img = %{$exif->get_image_info()|| {} }; my %exif = ( width => $exif_img{'Image Width'}, height=> $exif_img{'Image Height'}, date => $exif_img{'Image Created'}, ); return \%exif; } __END__

There are no rules, there are no thumbs..
Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.

Comment on Tk image resizer
Select or Download Code
Re: Tk image resizer
by RonW (Pilgrim) on May 05, 2014 at 22:45 UTC

    Nice tool

    Question: You say: Using Image::Resize the ratio is maintained for the original photo, ie only the width will be used, while the height will be adjusted as needed. If height is not used, why ask for it? Also, maybe there's a way to force resize to use it. If the height parameter is optional, then specifying it would be a way to indicate desire to force its use.

      this was born as quick hack, as always..
      I think is simpler to remember that you need to pass a width X height x infix then others things. You can easyly modify the code to change both dimension if it is what you want (from module documentation):
      resize($width, $height, $constraint); Returns a GD::Image object for the new, resized image. Original image +is not modified. This lets you create multiple thumbnails of an image + using the same Image::Resize object. First two arguments are required, which define new image dimensions. B +y default resize() retains image proportions while resizing. This is +always what you expect to happen. In case you don't care about retain +ing image proportions, pass 0 as the third argument to resize().

      L*
      There are no rules, there are no thumbs..
      Reinvent the wheel, then learn The Wheel; may be one day you reinvent one of THE WHEELS.

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://1085037]
Front-paged by Arunbear
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others drinking their drinks and smoking their pipes about the Monastery: (9)
As of 2014-08-20 05:04 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    The best computer themed movie is:











    Results (105 votes), past polls