The idea is that this will resize, autolevel, and recompress a bunch of jpegs at a time. I finally wrote it because one of the neighbors I support needed it to be able to process tons of pictures for the local humane society, and can't learn to use a photo editor, like the gimp, and walk through all the stuff I normally do to post here, depending on what's not quite right in a picture I took.
The net result with their super-megapixel camera they don't or can't adjust resolution on is that they can't send more than about 1 photo in an email to a prospective animal adopter.
I may fool with adding an auto-sharpening, as they have trouble getting un-blurred pictures of moving animals.
And I do all this stuff to post here myself....so, why not make it easier on me? And, oh yes, you, if you can run this.
Here's what it looks like when run on a directory:
- Screenshot
What's nice about this, in linux, is that if you install it in /home/username/.gnome2/nautilis-scripts and make it executable, it will show up as a right click option in the Nautilus file browser in linux, and let you do selected files and directories really quick and easy. Like you get from the linux camera capture program, F-spot. It does this in-place, which is one of the tradeoffs.
To do that in windows, I think there's a registry edit you can do, but I forgot what it was.
I could probably have written this in a fraction of the lines (perl's like that) but...I want to be able to understand it later, and use pieces of this as examples for my bag o' tricks, so I wrote it long winded and as clear as was reasonable. If you want to understand what I'm doing in the program, make sure and use a syntax highlighting editor that knows perl to view it in. Gedit is probably easiest in linux, it's what I wrote it in. There are also Geany and Padre, but I just didn't need that level of stuff.
Here it is with a .txt extension to fool the board into allowing it as an attachment.
Photo_Shrink.txt- Code file for program
- (8.16 KiB) Downloaded 286 times
You'd want to strip or change the extension for your system. Here it just doesn't have one at all.
And here it is in all it's ugly glory for those who can't download:
Can't even read it myself without the color syntax, so don't leave home without that little aid to clarity.
- Code: Select all
#!/usr/bin/perl -w
use Tk;
use Cwd;
use Image::Magick;
use strict;
# Copyright License -- GPL v2. If you change this, please send me a copy at clab@swva.net, and make your changes
# public. We're supposed to be helping each other. Not tested on windows, but should work if you can find a
#Tk library for windows (or build it again from source on CPAN) -- activestate doesn't have it anymore.
# requires perl modules Tk, PerlMagick (or, Image::Magick, and application ImageMagick
#(Cwd is a standard one for most perls)
# Install this in home/user/.gnome2/nautilus-scripts to have it as a right click option after selecting files
# or directories in Nautilus. Don't forget to make it executable.
# This is a program to work as a nautilus-script to perform some processing on all .jpg's in
# the input arguments. The idea is to make it simple to shrink and compress a bunch of huge
# megapixel photos from a camera in an f-spot directory into something you can email or post
# on the web without it being too doggone huge for that. Tk is used for the GUI, as it (should) be
# pretty simple.
# Images are modified IN PLACE and THE ORIGINALS ARE WIPED. Saves a step for most users.
# Contact me if you need something fancier, or do the code and send me a copy if you figure out how
# to handle the case of where to put the new, or keep from having both old and new in the same dir if
# a user does it again on the same files by accident...
# When run from the command line, any set of names and directories can be used as arguments, and
# if there are some errors (that I check for), you'll get them on stdout. Else they go in the bit bucket.
# Amazingly on the latest kernel for ubuntu 10.04 LTS, all available cpu cores are used in parallel.
# So this can be nicely quick -- but that's not my fault! It just did it! Way cool on a quad core.
# these need to be visible to the whole program
my $mw;
my $flbltxt; # list of full file paths to process, for display to user so they can decide not to, if...
my $cwd; # where are we looking - and maybe where the results go (root if there are subdirs)
my @infilepaths; # list of files to process, global
# I didn't get fancy enough to have a config file, here's the defaults for you to change as desired
# I also don't check if you put legal numbers in here - be careful. They have to match the options
# in the radio buttons (search for Radiobutton below)
my $resize = 1; # boolean for do resize
my $autolevel = 1; # ditto for auto level
my $newwidth = 640; # new X size (scale maintained)
my $changequality = 1; # bool for do compresson change
my $newquality = 60; # new compression quality if desired
#################### subroutines
#////////////////////////////////////////////////////////////////
sub dofiles
{ # actually run all the files through the processing selected in the GUI
my $ipath;
my $image = Image::Magick->new;
my $x; # error variable
my $geo;
foreach $ipath (@infilepaths)
{
$x = $image->Read($ipath); # get current image into ram
warn "$x" if "$x";
# $x = $image->get('quality'); # evidently same scale as gimp uses, 1-99
# print ("\nQuality of $ipath:$x");
if ($resize)
{
$geo = "$newwidth" .'x'."$newwidth"; # I'm sure I missed a slick trick to get this line free, impatient
$x = $image->Resize(geometry => $geo, filter => 'Cubic');
warn "$x" if "$x";
}
if ($autolevel)
{ # adjust total brightness/contrast to fill the available space
$x = $image->AutoLevel();
warn "$x" if "$x";
}
if ($changequality) # changes the compression level for jpegs
{ # nothing beats cutting down the total pixels, but this helps a lot too
$x = $image->Set(quality => $newquality);
warn "$x" if "$x";
}
# could add more transforms here (along with GUI elsewhere)
$x = $image->Write($ipath); # overwrite the original image with the new
warn "$x" if "$x";
# update display here...so we know it's working and user is comfortable
$flbltxt =~ s/$ipath//; # remove the one we just finished
$mw->update(); # and draw the new text on screen so user can see we're working
@$image = (); # clear out object for reuse, don't fill up memory
} # end for each image
undef $image; #done with this, be clean (same as C++ delete)
exit 0; # we're done entirely at this point, so go away
}
#////////////////////////////////////////////////////////////////
# find files to process according to my particular rule-set. In this case, jpegs only,
# and we can handle a mixed list of directories and files as input from Nautilus or command line
# we'll go down into a directory, but not recurse past that -- else user might get in big trouble
sub findfiles
{
my $name;
my $dcwd; # for single level descent into a directory, no recursion here
@infilepaths = (); # in case someday we go more than once on this routine
$cwd = getcwd; # base dir for other filenames
# check first arg(s), if dir, expand that dir. If a file(s), get all args to a filepath list
# not perfect probably, but gotta have some plan at all
foreach $name (@ARGV) # could be just a filename, or a whole directory (we won't recurse below that)
{
next if $name =~ /\.\.?$/; # skip . and .. if they are present
if (-f "$cwd/$name") # simple case, just a file name
{
push (@infilepaths, "$cwd/$name") if $name =~ m/\.jpg|\.jpeg/i; # add it to the list
}
elsif (-d "$cwd/$name") # it's a directory, so go fishing down inside it instead
{
$dcwd = "$cwd/$name"; # new directory to look for files in
opendir(DIR, $dcwd) or die "can't open $dcwd: $!";
while (defined($name = readdir(DIR)))
{ # test file and add if it's a good one
next if $name =~ /\.\.?$/; # skip . and .. if they are present
# now check each for being a file and a jpg both (could have done a one-liner here and above)
if (-f "$dcwd/$name")
{
push (@infilepaths,"$dcwd/$name") if $name =~ m/\.jpg|\.jpeg/i;
}
} # end each file in subdir
closedir(DIR); # clean up after self
} # end if directory
} # for argv input
$flbltxt .= join ("\n",@infilepaths); # show user what we're about to work on
} # end findfiles()
####################### main #############################
my $btframe; # frame for buttons on bottom
my $qbutton;
my $gobutton;
my $tframe;
my $t2frame;
my $t3frame;
my $mframe;
my $label;
my $flabel;
$mw = MainWindow->new;
$mw->title("Batch Photo Shrinker"); # save them bytes
# make some frame windows to organize where things go in the GUI
$btframe = $mw->Frame(-relief => 'groove', -borderwidth => 2)->pack(-side => 'bottom',-fill => 'x');
$tframe = $mw->Frame(-relief => 'groove', -borderwidth => 2)->pack(-side => 'top',-fill => 'x');
$t2frame = $mw->Frame(-relief => 'groove', -borderwidth => 2)->pack(-side => 'top',-fill => 'x');
$t3frame = $mw->Frame(-relief => 'groove', -borderwidth => 2)->pack(-side => 'top',-fill => 'x');
$mframe = $mw->Frame(-relief => 'groove', -borderwidth => 2)->pack(-side => 'top',-fill => 'x');
# bottom frame stuff
$gobutton = $btframe->Button(-text => "Do them all", -command => sub { \dofiles })
->pack(-expand => 1, -side => 'left', -fill => 'x');
$qbutton = $btframe->Button(-text => "Exit", -command => sub { exit 0 }, -cursor => 'pirate')
->pack(-expand => 1, -side => 'right', -fill => 'x');
#top frame stuff
# controls for image processing parameters
my $rs = $tframe->Checkbutton(-text => "Resize?", -variable => \$resize)->pack(-side => 'left');
foreach (qw(160 320 640 1024 1280))
{
$tframe->Radiobutton(-text => $_,-value => $_,-variable => \$newwidth)->pack(-side => 'left', -expand => 1,
-fill =>'both');
}
# t2 frame for next batch o' controls
my $cq = $t2frame->Checkbutton(-text => "Change compression quality?", -variable => \$changequality)->
pack(-side => 'left');
foreach (qw(40 50 60 70 80))
{
$t2frame->Radiobutton(-text => $_,-value => $_,-variable => \$newquality)->pack(-side => 'left');
}
# bottom of control frames
my $al = $t3frame->Checkbutton(-text => "AutoLevel?", -variable => \$autolevel, -anchor => 'w')->
pack(-side => 'left');
# bottom-middle frame stuff
$label = $mframe->Label(-text =>"**************** Files found: ****************")->pack(-side => 'top');
$flabel = $mframe->Label(-textvariable => \$flbltxt)->pack(-side => 'bottom');
# some debug stuff to see what Nautilus was handing this script as arguments with various things selected
# had to do it this way as we don't have stdout then.
#$flbltxt = join ("\n",@ARGV);
#$flbltxt .= "\n........\n";
#$flbltxt .= getcwd;
#$flbltxt .= "\nend\n";
findfiles(); # find all the jpegs in current arguments, show list to user before they hit go
MainLoop; # draw the windows and process events
# fall out when user hits exit, or finished via exit in dofiles()
exit 0;
