Оформил: DeeCo
Автор: http://www.swissdelphicenter.ch

{ 

  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}