Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

Comment on

( #3333=superdoc: 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.

In reply to Tk image resizer by Discipulus

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • Outside of code tags, you may need to use entities for some characters:
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others rifling through the Monastery: (10)
    As of 2014-10-23 21:46 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      For retirement, I am banking on:










      Results (129 votes), past polls