Изменение размеров 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;
 end;
end;
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;
 except
 Result := False; // Oops...never Loaded, so return False.
 end;
 end;
end;
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;
 end;
 end;
 except
 raise;
 Result := False;
 end;
end;
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;
 end;
 end;
 finally
 OldBitmap.Free;
 end;
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;
 end;
 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;
 end;
 end;
 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;
 end;
end;
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 03792
----
загрузи в bitmap, измени размеры, сделай Stretch и сохрани.
procedure TForm1.Button1Click(Sender: TObject);
var
 bmp: TBitmap;
 jpg: TJpegImage;
 scale: Double;
begin
 if OpenDialog1.Execute then
 begin
 jpg := TJpegImage.Create;
 try
 jpg.LoadFromFile(OpenDialog1.FileName);
 if jpg.Height > jpg.Width then
 scale := 50 / jpg.Height
 else
 scale := 50 / jpg.Width;
 bmp := Tbitmap.Create;
 try
 { Create thumbnail bitmap, keep pictures aspect ratio }
 bmp.Width := Round(jpg.Width * scale);
 bmp.Height:= Round(jpg.Height * scale);
 bmp.Canvas.StretchDraw(bmp.Canvas.Cliprect, jpg);
 { Draw thumbnail as control }
 Self.Canvas.Draw(100, 10, bmp);
 { Convert back to JPEG and save to file }
 jpg.Assign(bmp);
 jpg.SaveToFile(ChangeFileext(OpenDialog1.FileName, '_thumb.JPG'));
 finally
 bmp.Free;
 end;
 finally
 jpg.Free;
 end;
 end;
end;
Не забудь USES Jpeg;
Author: RoboSol 
Source: http://forum.sources.ru
ID: 03793
Category:Графика
Category:Jpeg
Category:Bitmap