Resize a *.jpg image and save the result to a file (2)

Problem/Question/Abstract:

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?

Answer:

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.

{ ... }
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;
      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 to load - return false ...}
    Result := false
  else
  begin
    try
      JPEGImage := TJPEGImage.Create;
      try
        JPEGImage.LoadFromFile(FilePath + Filename);
        Bitmap.Assign(JPEGImage);
        Result := true;
      finally
        JPEGImage.Free;
      end;
    except
      Result := 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;

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;