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

Generate thumbnail and small overstruck images for web publication

by GrandFather (Sage)
on Sep 19, 2005 at 11:01 UTC ( #493122=CUFP: print w/replies, xml ) Need Help??

This script uses Image::Magick to generate pairs of images for each image in a directory tree. The names for the images are generated using the given directory name as a template. Text provided on the command line is used to overstrike each small image (but not the thumbnail) using translucent text.

use strict; use warnings; use Image::Magick; use File::Spec::Functions qw(splitpath); use File::Find; my $thumbX = 100; my $thumbY = 66; my $smallX = 443; my $smallY = 293; my $ratio = $smallX / $smallY; if (@ARGV == 0) { print "Prepares the graphics files from the folder passed on the c +ommand line\n". "for publication on a web site. The files are first renamed usin +g\n". "the folder name as the name of the first image. A thumbnail ima +ge is\n". "then generated with the suffix _sm. Finally a small image is ge +nerated\n". "and overprinted with text provided as the first item on the com +mand line.\n". "\n". "PrepPhotos <brand text> <folders list>\n". "\n". "The <brand text> must be quoted unless it is a single word.\n". "Only .jpg and .gif files are processed. Multiple folders may be + supplied.\n". "Folder names should not include punctuation. Folder names shoul +d contain\n". "as many trailing 0's as are to be used in the serial number. Fo +r example\n". "BAR000 would allow images BAR000 - BAR999 to be generated. Odd +things\n". "will happen if too few digits are allowed for. The images are n +umbered\n". "starting with the given sequence number.\n"; exit (1); } my $overText = shift; my $overL = Image::Magick->new(); my $overP = Image::Magick->new(); my $points = 50; $overL->Set (size=>"1x1"); $overL->ReadImage('xc:#808080'); # Nochange colour for Hardlight my ($x_ppem, $y_ppem, $ascender, $descender, $width, $height, $max_adv +ance) = $overL->QueryFontMetrics ( pointsize => $points, text => "$overText", '@C:/WINDOWS/Fonts/times.ttf', # Omit for default font ); $width *= 1.2; $overL->Resize (width => $width, height => $height); $overL->Annotate ( pointsize => $points, text => "$overText", gravity=>'center', stroke => '#C0C0C0', # Increase to make stroke more white fill => '#505050', # Decrease to make fill more black '@C:/WINDOWS/Fonts/times.ttf', # Omit for default font ); $height /= $width / $smallX; # Maintain font aspect ratio $overL->Resize (width=>$smallX, height=>$height); # Scale width to ima +ge size $overP = $overL->Clone (); $overP->Resize (width=>$smallY, height=>$height * $smallY / $smallX); my $imageNumber; for (@ARGV) { ($imageNumber) = $_ =~ /(\w+)$/; find (\&process, $_); } print "Finished\n"; sub process {# process each file my $filename = $File::Find::name; my ($ext) = $filename =~ /(\..*?)$/; return if $filename !~ /\.(?:jpg|gif)$/i; return if -d $filename; my ($drive, $dir, $file) = splitpath ($filename); print "\nProcessing: $filename -> $imageNumber$ext\n"; my $image = Image::Magick->new (); my $thumb = Image::Magick->new (); $image->ReadImage ($filename); $thumb = $image->Clone (); my ($height, $width) = $image->Get ('height', 'width'); my $portrait = $height > $width; my ($x, $y) = ! $portrait ? ($thumbX, $thumbY) : ($thumbY, $thumbX); my $scaleX = $x / $width; my $scaleY = $y / $height; my $scale = $scaleX < $scaleY ? $scaleX : $scaleY; $thumb->Resize (width=>$width * $scale+0.5, height=>$height * $scale ++0.5); $thumb->Write ("$drive$dir${imageNumber}_sm$ext"); ($x, $y) = ! $portrait ? ($smallX, $smallY) : ($smallY, $smallX); $scaleX = $x / $width; $scaleY = $y / $height; $scale = $scaleX < $scaleY ? $scaleX : $scaleY; $image->Resize (width=>$width * $scale+0.5, height=>$height * $scale ++0.5); $image->Composite ( compose=>'Hardlight', image=> $portrait ? $overP : $overL, gravity=>'center' ); $image->Write ("$drive${dir}${imageNumber}$ext"); ++$imageNumber; }

The code is somewhat Windows oriented. The font used by Annotate may need to be fixed and the file extension management (look for $ext) are likely to need attention on other platforms.

Perl is Huffman encoded by design.

Replies are listed 'Best First'.
Re: Generate thumbnail and small overstruck images for web publication
by blazar (Canon) on Sep 19, 2005 at 13:18 UTC
    I gave just a quick look at your program. I have just a {question,suggestion}: why print and exit instead of die? Well, maybe you don't want it to fail... also I would use an HERE doc in this case:
    die <<"EOMESSAGE" unless @ARGV; Begin long message... ... End long message EOMESSAAGE

      Fair comment. It's the C/C++ shining through I guess :). I seldom think of HERE docs, but that would be a much tider way to do that.

      In actual use the script is accessed through a desktop short cut and the folders to be processed are drag and dropped onto the short cut. The print could probably be replaced with POD.

      Perl is Huffman encoded by design.
Re: Generate thumbnail and small overstruck images for web publication
by McDarren (Abbot) on Sep 19, 2005 at 11:45 UTC

    I've been using a bash script for a couple of years (also in combination with imagemagick) to do something very similar, and I've been thinking of re-writing it in Perl for a while now.

    You've just given me a big jump start, thanks :)
Re: Generate thumbnail and small overstruck images for web publication
by Intrepid (Deacon) on Sep 26, 2005 at 10:38 UTC

    In GrandFather's code there did appear this:

    my ($x_ppem, $y_ppem, $ascender, $descender, $width, $height, $max_a +dvance) = $overL->QueryFontMetrics ( pointsize => $points, text => "$overText", '@C:/WINDOWS/Fonts/times.ttf', # Omit for default font );

    In order to enhance portability I would suggest a mild wrapper around the font -finding parameter (untested as of this posting):

    my $mswinpath; my $fontpath = ($mswinpath = $ENV{SYSTEMDIR} || $ENV{WINDIR}) ? q[@]. $mswinpath .q[/Fonts/times.ttf] : q[times]; $fontpath =~ tr:\\:/:s; my ($x_ppem, $y_ppem, $ascender, $descender, $width, $height, $max_a +dvance) = $overL->QueryFontMetrics ( pointsize => $points, text => "$overText", $fontpath );

    I'm not certain that 'times' is a valid font specifier on X11 (*nix) systems, but I suspect that it will work fairly widely.

Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: CUFP [id://493122]
Approved by Corion
and all is quiet...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (6)
As of 2017-04-26 20:39 GMT
Find Nodes?
    Voting Booth?
    I'm a fool:

    Results (488 votes). Check out past polls.