JPG Resize (Scale High Quality)

uses Jpeg, ShellApi

function DeleteFile(const AFile: string): boolean;
var
 sh: SHFileOpStruct;
begin
 ZeroMemory(@sh, sizeof(sh));
 with sh do
   begin
   Wnd := Application.Handle;
   wFunc := fo_Delete;
   pFrom := PChar(AFile +#0);
   fFlags := fof_Silent or fof_NoConfirmation;
   end;
 result := SHFileOperation(sh) = 0;
end;

procedure Bmp2Jpeg(const BmpFileName, JpgFileName: string);
var
  Bmp: TBitmap;
  Jpg: TJPEGImage;
begin
  Bmp := TBitmap.Create;
  Jpg := TJPEGImage.Create;
  try
    Bmp.LoadFromFile(BmpFileName);
    Jpg.Assign(Bmp);
    Jpg.SaveToFile(JpgFileName);
  finally
    Jpg.Free;
    Bmp.Free;
  end;
end;

procedure Jpeg2Bmp(const BmpFileName, JpgFileName: string);
var
  Bmp: TBitmap;
  Jpg: TJPEGImage;
begin
  Bmp := TBitmap.Create;
  Jpg := TJPEGImage.Create;
  try
    Jpg.LoadFromFile(JpgFileName);
    Bmp.Assign(Jpg);
    Bmp.SaveToFile(BmpFileName);
  finally
    Jpg.Free;
    Bmp.Free;
  end;
end;

procedure ResizeBmp(Dest: TBitmap; const WMax, HMax: Word);
type
  pRGBArray = ^TRGBArray;
  TRGBArray = array[Word] of TRGBTriple;
var
  TBmp: TBitmap;
  DstGap: Integer;
  WNew, HNew: Integer;
  X, Y, T3: Integer;
  Z1, Z2, IZ2: Integer;
  W1, W2, W3, W4: Integer;
  XP, XP2, YP, YP2: Integer;
  SrcLine1, SrcLine2, DstLine: pRGBArray;
Begin
  TBmp := TBitmap.Create;
  try
    try
      WNew := (Dest.Width * HMax) div Dest.Height;
      HNew := (WMax * Dest.Height) div Dest.Width;
      if (WMax < WNew) then
      begin
        TBmp.Width := WMax;
        TBmp.Height := HNew;
      end else
      begin
        TBmp.Width := WNew;
        TBmp.Height := HMax;
      end;
      Dest.PixelFormat := pf24Bit;
      TBmp.PixelFormat := pf24bit;
      DstLine := TBmp.ScanLine[0];
      DstGap  := Integer(TBmp.ScanLine[1]) - Integer(DstLine);
      XP2 := MulDiv(Pred(Dest.Width), $10000, TBmp.Width);
      YP2 := MulDiv(Pred(Dest.Height), $10000, TBmp.Height);
      YP  := 0;
      for Y := 0 to Pred(TBmp.Height) do
      begin
        XP := 0;
        SrcLine1 := Dest.ScanLine[YP shr 16];
        if (YP shr 16 < Pred(Dest.Height))
          then SrcLine2 := Dest.ScanLine[Succ(YP shr 16)]
          else SrcLine2 := Dest.ScanLine[YP shr 16];
        Z2  := Succ(YP and $FFFF);
        IZ2 := Succ((not YP) and $FFFF);
        for X := 0 to Pred(TBmp.Width) do
        begin
          T3 := XP shr 16;
          Z1 := XP and $FFFF;
          W2 := MulDiv(Z1, IZ2, $10000);
          W1 := IZ2 - W2;
          W4 := MulDiv(Z1, 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;
        Inc(YP, YP2);
        DstLine := pRGBArray(Integer(DstLine) + DstGap);
      end;
      Dest.Assign(TBmp);
    except
    end;
  finally
    TBmp.Free;
  end;
  Screen.Cursor := crDefault;
end;

Beispiel :

procedure TForm1.Button1Click(Sender: TObject);
var
  jpg : TJPEGImage;
  BMP : TBitmap;
begin
  jpg := TJPEGImage.Create;
  bmp := TBitmap.Create;
  if OpenDialog1.Execute then begin
    Screen.Cursor := crHourGlass;
    jpg.LoadFromFile(OpenDialog1.FileName);
    Jpeg2Bmp(OpenDialog1.FileName + '.bmp', OpenDialog1.FileName);
    BMP.LoadFromFile(OpenDialog1.FileName + '.bmp');
    try
      BMP.PixelFormat := pf24bit;

      ResizeBmp(BMP,
                800,   // HIER DIE HÖHE ANGEBEN
                800);  // HIER DIE BREITE ANGEBEN

      BMP.SaveToFile(OpenDialog1.FileName + '.bmp');
      Bmp2Jpeg(OpenDialog1.FileName + '.bmp', OpenDialog1.FileName + '.jpg');
    finally
    DeleteFile(OpenDialog1.FileName + '.bmp');
    bmp.Free;
    jpg.Free;
    end;
  end;
end;