Smoothly Resize a JPEG Image?
{
Before importing an image (jpg) into a database,
I would like to resize it (reduce its size) and
generate the corresponding smaller file. How can I do this?
Load the JPEG into a bitmap, create a new bitmap
of the size that you want and pass them both into
SmoothResize then save it again ...
there's a neat routine JPEGDimensions that
gets the JPEG dimensions without actually loading the JPEG into a bitmap,
saves loads of time if you only need to test its size before resizing.
}
uses
JPEG;
type
TRGBArray = array[Word] of TRGBTriple;
pRGBArray = ^TRGBArray;
{---------------------------------------------------------------------------
-----------------------}
procedure SmoothResize(Src, Dst: TBitmap);
var
x, y: Integer;
xP, yP: Integer;
xP2, yP2: Integer;
SrcLine1, SrcLine2: pRGBArray;
t3: Integer;
z, z2, iz2: Integer;
DstLine: pRGBArray;
DstGap: Integer;
w1, w2, w3, w4: Integer;
begin
Src.PixelFormat := pf24Bit;
Dst.PixelFormat := pf24Bit;
if (Src.Width = Dst.Width) and (Src.Height = Dst.Height) then
Dst.Assign(Src)
else
begin
DstLine := Dst.ScanLine[0];
DstGap := Integer(Dst.ScanLine[1]) - Integer(DstLine);
xP2 := MulDiv(pred(Src.Width), $10000, Dst.Width);
yP2 := MulDiv(pred(Src.Height), $10000, Dst.Height);
yP := 0;
for y := 0 to pred(Dst.Height) do
begin
xP := 0;
SrcLine1 := Src.ScanLine[yP shr 16];
if (yP shr 16 < pred(Src.Height)) then
SrcLine2 := Src.ScanLine[succ(yP shr 16)]
else
SrcLine2 := Src.ScanLine[yP shr 16];
z2 := succ(yP and $FFFF);
iz2 := succ((not yp) and $FFFF);
for x := 0 to pred(Dst.Width) do
begin
t3 := xP shr 16;
z := xP and $FFFF;
w2 := MulDiv(z, iz2, $10000);
w1 := iz2 - w2;
w4 := MulDiv(z, z2, $10000);
w3 := z2 - w4;
DstLine[x].rgbtRed := (SrcLine1[t3].rgbtRed * w1 +
SrcLine1[t3 + 1].rgbtRed * w2 +
SrcLine2[t3].rgbtRed * w3 + SrcLine2[t3 + 1].rgbtRed * w4) shr 16;
DstLine[x].rgbtGreen :=
(SrcLine1[t3].rgbtGreen * w1 + SrcLine1[t3 + 1].rgbtGreen * w2 +
SrcLine2[t3].rgbtGreen * w3 + SrcLine2[t3 + 1].rgbtGreen * w4) shr 16;
DstLine[x].rgbtBlue := (SrcLine1[t3].rgbtBlue * w1 +
SrcLine1[t3 + 1].rgbtBlue * w2 +
SrcLine2[t3].rgbtBlue * w3 +
SrcLine2[t3 + 1].rgbtBlue * w4) shr 16;
Inc(xP, xP2);
end; {for}
Inc(yP, yP2);
DstLine := pRGBArray(Integer(DstLine) + DstGap);
end; {for}
end; {if}
end; {SmoothResize}
{---------------------------------------------------------------------------
-----------------------}
function LoadJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string): Boolean;
var
JPEGImage: TJPEGImage;
begin
if (FileName = '') then // No FileName so nothing
Result := False //to load - return False...
else
begin
try // Start of try except
JPEGImage := TJPEGImage.Create; // Create the JPEG image... try // now
try // to load the file but
JPEGImage.LoadFromFile(FilePath + FileName);
// might fail...with an Exception.
Bitmap.Assign(JPEGImage);
// Assign the image to our bitmap.Result := True;
// Got it so return True.
finally
JPEGImage.Free; // ...must get rid of the JPEG image. finally
end; {try}
except
Result := False; // Oops...never Loaded, so return False.
end; {try}
end; {if}
end; {LoadJPEGPictureFile}
{---------------------------------------------------------------------------
-----------------------}
function SaveJPEGPictureFile(Bitmap: TBitmap; FilePath, FileName: string;
Quality: Integer): Boolean;
begin
Result := True;
try
if ForceDirectories(FilePath) then
begin
with TJPegImage.Create do
begin
try
Assign(Bitmap);
CompressionQuality := Quality;
SaveToFile(FilePath + FileName);
finally
Free;
end; {try}
end; {with}
end; {if}
except
raise;
Result := False;
end; {try}
end; {SaveJPEGPictureFile}
{---------------------------------------------------------------------------
-----------------------}
procedure ResizeImage(FileName: string; MaxWidth: Integer);
var
OldBitmap: TBitmap;
NewBitmap: TBitmap;
aWidth: Integer;
begin
OldBitmap := TBitmap.Create;
try
if LoadJPEGPictureFile(OldBitmap, ExtractFilePath(FileName),
ExtractFileName(FileName)) then
begin
aWidth := OldBitmap.Width;
if (OldBitmap.Width > MaxWidth) then
begin
aWidth := MaxWidth;
NewBitmap := TBitmap.Create;
try
NewBitmap.Width := MaxWidth;
NewBitmap.Height := MulDiv(MaxWidth, OldBitmap.Height, OldBitmap.Width);
SmoothResize(OldBitmap, NewBitmap);
RenameFile(FileName, ChangeFileExt(FileName, '.$$$'));
if SaveJPEGPictureFile(NewBitmap, ExtractFilePath(FileName),
ExtractFileName(FileName), 75) then
DeleteFile(ChangeFileExt(FileName, '.$$$'))
else
RenameFile(ChangeFileExt(FileName, '.$$$'), FileName);
finally
NewBitmap.Free;
end; {try}
end; {if}
end; {if}
finally
OldBitmap.Free;
end; {try}
end;
{---------------------------------------------------------------------------
-----------------------}
function JPEGDimensions(Filename : string; var X, Y : Word) : boolean;
var
SegmentPos : Integer;
SOIcount : Integer;
b : byte;
begin
Result := False;
with TFileStream.Create(Filename, fmOpenRead or fmShareDenyNone) do
begin
try
Position := 0;
Read(X, 2);
if (X <> $D8FF) then
exit;
SOIcount := 0;
Position := 0;
while (Position + 7 < Size) do
begin
Read(b, 1);
if (b = $FF) then begin
Read(b, 1);
if (b = $D8) then
inc(SOIcount);
if (b = $DA) then
break;
end; {if}
end; {while}
if (b <> $DA) then
exit;
SegmentPos := -1;
Position := 0;
while (Position + 7 < Size) do
begin
Read(b, 1);
if (b = $FF) then
begin
Read(b, 1);
if (b in [$C0, $C1, $C2]) then
begin
SegmentPos := Position;
dec(SOIcount);
if (SOIcount = 0) then
break;
end; {if}
end; {if}
end; {while}
if (SegmentPos = -1) then
exit;
if (Position + 7 > Size) then
exit;
Position := SegmentPos + 3;
Read(Y, 2);
Read(X, 2);
X := Swap(X);
Y := Swap(Y);
Result := true;
finally
Free;
end; {try}
end; {with}
end; {JPEGDimensions}