How to resize a picture?

I have image (500x500) but I need to resize it to 200x200 and paint it on TImage. How to achieve such result?

Note
I know about Stretch property in TImage, but I want to resize the image programmatically.

Solution 1:

If you know that the new dimensions are not greater than the original ones, you can simply do

procedure ShrinkBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer);
begin
  Bitmap.Canvas.StretchDraw(
    Rect(0, 0, NewWidth, NewHeight),
    Bitmap);
  Bitmap.SetSize(NewWidth, NewHeight);
end;

I leave it as an exercise to write the corresponding code if you know that the new dimensions are not smaller than the original ones.

If you want a general function, you could do

procedure ResizeBitmap(Bitmap: TBitmap; const NewWidth, NewHeight: integer);
var
  buffer: TBitmap;
begin
  buffer := TBitmap.Create;
  try
    buffer.SetSize(NewWidth, NewHeight);
    buffer.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bitmap);
    Bitmap.SetSize(NewWidth, NewHeight);
    Bitmap.Canvas.Draw(0, 0, buffer);
  finally
    buffer.Free;
  end;
end;

This approach has the downside of doing two pixel-copy operations. I can think of at least two solutions to that problem. (Which?)

Solution 2:

Great usability and picture quality offers the ResizeImage function(s) from the unit¹⁾ below. The code depends on Graphics32, GIFImage²⁾ and PNGImage²⁾.

The function takes two file names or two streams. Input is (automatically detected as) BMP, PNG, GIF or JPG, output is always JPG.

unit AwResizeImage;

interface

uses
  Windows, SysUtils, Classes, Graphics, Math, JPEG, GR32, GIFImage, PNGImage,
  GR32_Resamplers;

type
  TImageType = (itUnknown, itBMP, itGIF, itJPG, itPNG);
  TImageInfo = record
    ImgType: TImageType;
    Width: Cardinal;
    Height: Cardinal;
  end;

  function GetImageInfo(const AFilename: String): TImageInfo; overload;
  function GetImageInfo(const AStream: TStream): TImageInfo; overload;

  function ResizeImage(const ASource, ADest: String; const AWidth,
    AHeight: Integer; const ABackColor: TColor;
    const AType: TImageType = itUnknown): Boolean; overload;
  function ResizeImage(const ASource, ADest: TStream; const AWidth,
    AHeight: Integer; const ABackColor: TColor;
    const AType: TImageType = itUnknown): Boolean; overload;

implementation

type
  TGetDimensions = procedure(const ASource: TStream;
    var AImageInfo: TImageInfo);

  TCardinal = record
    case Byte of
      0: (Value: Cardinal);
      1: (Byte1, Byte2, Byte3, Byte4: Byte);
  end;

  TWord = record
    case Byte of
      0: (Value: Word);
      1: (Byte1, Byte2: Byte);
  end;

  TPNGIHDRChunk = packed record
    Width: Cardinal;
    Height: Cardinal;
    Bitdepth: Byte;
    Colortype: Byte;
    Compression: Byte;
    Filter: Byte;
    Interlace: Byte;
  end;

  TGIFHeader = packed record
    Signature: array[0..2] of Char;
    Version: array[0..2] of Char;
    Width: Word;
    Height: Word;
  end;

  TJPGChunk = record
    ID: Word;
    Length: Word;
  end;

  TJPGHeader = packed record
    Reserved: Byte;
    Height: Word;
    Width: Word;
  end;

const
  SIG_BMP: array[0..1] of Char = ('B', 'M');
  SIG_GIF: array[0..2] of Char = ('G', 'I', 'F');
  SIG_JPG: array[0..2] of Char = (#255, #216, #255);
  SIG_PNG: array[0..7] of Char = (#137, #80, #78, #71, #13, #10, #26, #10);

function SwapBytes(const ASource: Cardinal): Cardinal; overload;
var
  mwSource: TCardinal;
  mwDest: TCardinal;
begin
  mwSource.Value := ASource;
  mwDest.Byte1 := mwSource.Byte4;
  mwDest.Byte2 := mwSource.Byte3;
  mwDest.Byte3 := mwSource.Byte2;
  mwDest.Byte4 := mwSource.Byte1;
  Result := mwDest.Value;
end;

function SwapBytes(const ASource: Word): Word; overload;
var
  mwSource: TWord;
  mwDest: TWord;
begin
  mwSource.Value  := ASource;
  mwDest.Byte1 := mwSource.Byte2;
  mwDest.Byte2 := mwSource.Byte1;
  Result := mwDest.Value;
end;

procedure GetBMPDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
  bmpFileHeader: TBitmapFileHeader;
  bmpInfoHeader: TBitmapInfoHeader;
begin
  FillChar(bmpFileHeader, SizeOf(TBitmapFileHeader), #0);
  FillChar(bmpInfoHeader, SizeOf(TBitmapInfoHeader), #0);
  ASource.Read(bmpFileHeader, SizeOf(TBitmapFileHeader));
  ASource.Read(bmpInfoHeader, SizeOf(TBitmapInfoHeader));
  AImageInfo.Width := bmpInfoHeader.biWidth;
  AImageInfo.Height := bmpInfoHeader.biHeight;
end;

procedure GetGIFDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
  gifHeader: TGIFHeader;
begin
  FillChar(gifHeader, SizeOf(TGIFHeader), #0);
  ASource.Read(gifHeader, SizeOf(TGIFHeader));
  AImageInfo.Width := gifHeader.Width;
  AImageInfo.Height := gifHeader.Height;
end;

procedure GetJPGDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
  cSig: array[0..1] of Char;
  jpgChunk: TJPGChunk;
  jpgHeader: TJPGHeader;
  iSize: Integer;
  iRead: Integer;
begin
  FillChar(cSig, SizeOf(cSig), #0);
  ASource.Read(cSig, SizeOf(cSig));
  iSize := SizeOf(TJPGChunk);
  repeat
    FillChar(jpgChunk, iSize, #0);
    iRead := ASource.Read(jpgChunk, iSize);
    if iRead <> iSize then
      Break;
    if jpgChunk.ID = $C0FF then
    begin
      ASource.Read(jpgHeader, SizeOf(TJPGHeader));
      AImageInfo.Width := SwapBytes(jpgHeader.Width);
      AImageInfo.Height := SwapBytes(jpgHeader.Height);
      Break;
    end
    else
      ASource.Position := ASource.Position + (SwapBytes(jpgChunk.Length) - 2);
  until False;
end;

procedure GetPNGDimensions(const ASource: TStream; var AImageInfo: TImageInfo);
var
  cSig: array[0..7] of Char;
  cChunkLen: Cardinal;
  cChunkType: array[0..3] of Char;
  ihdrData: TPNGIHDRChunk;
begin
  FillChar(cSig, SizeOf(cSig), #0);
  FillChar(cChunkType, SizeOf(cChunkType), #0);
  ASource.Read(cSig, SizeOf(cSig));
  cChunkLen := 0;
  ASource.Read(cChunkLen, SizeOf(Cardinal));
  cChunkLen := SwapBytes(cChunkLen);
  if cChunkLen = SizeOf(TPNGIHDRChunk) then
  begin
    ASource.Read(cChunkType, SizeOf(cChunkType));
    if AnsiUpperCase(cChunkType) = 'IHDR' then
    begin
      FillChar(ihdrData, SizeOf(TPNGIHDRChunk), #0);
      ASource.Read(ihdrData, SizeOf(TPNGIHDRChunk));
      AImageInfo.Width := SwapBytes(ihdrData.Width);
      AImageInfo.Height := SwapBytes(ihdrData.Height);
    end;
  end;
end;

function GetImageInfo(const AFilename: String): TImageInfo;
var
  fsImage: TFileStream;
begin
  fsImage := TFileStream.Create(AFilename, fmOpenRead or fmShareDenyWrite);
  try
    Result := GetImageInfo(fsImage);
  finally
    FreeAndNil(fsImage);
  end;
end;

function GetImageInfo(const AStream: TStream): TImageInfo;
var
  iPos: Integer;
  cBuffer: array[0..2] of Char;
  cPNGBuffer: array[0..4] of Char;
  GetDimensions: TGetDimensions;
begin
  GetDimensions := nil;
  Result.ImgType := itUnknown;
  Result.Width := 0;
  Result.Height := 0;
  FillChar(cBuffer, SizeOf(cBuffer), #0);
  FillChar(cPNGBuffer, SizeOf(cPNGBuffer), #0);
  iPos := AStream.Position;
  AStream.Read(cBuffer, SizeOf(cBuffer));
  if cBuffer = SIG_GIF then
  begin
    Result.ImgType := itGIF;
    GetDimensions := GetGIFDimensions;
  end
  else if cBuffer = SIG_JPG then
  begin
    Result.ImgType := itJPG;
    GetDimensions := GetJPGDimensions;
  end
  else if cBuffer = Copy(SIG_PNG, 1, 3) then
  begin
    AStream.Read(cPNGBuffer, SizeOf(cPNGBuffer));
    if cPNGBuffer = Copy(SIG_PNG, 4, 5) then
    begin
      Result.ImgType := itPNG;
      GetDimensions := GetPNGDimensions;
    end;
  end
  else if Copy(cBuffer, 1, 2) = SIG_BMP then
  begin
    Result.ImgType := itBMP;
    GetDimensions := GetBMPDimensions;
  end;
  AStream.Position := iPos;
  if Assigned(GetDimensions) then
  begin
    GetDimensions(AStream, Result);
    AStream.Position := iPos;
  end;
end;

procedure GIFToBMP(const ASource: TStream; const ADest: TBitmap);
var
  imgSource: TGIFImage;
begin
  imgSource := TGIFImage.Create();
  try
    imgSource.LoadFromStream(ASource);
    ADest.Assign(imgSource);
  finally
    FreeAndNil(imgSource);
  end;
end;

procedure JPGToBMP(const ASource: TStream; const ADest: TBitmap);
var
  imgSource: TJPEGImage;
begin
  imgSource := TJPEGImage.Create();
  try
    imgSource.LoadFromStream(ASource);
    ADest.Assign(imgSource);
  finally
    FreeAndNil(imgSource);
  end;
end;

procedure PNGToBMP(const ASource: TStream; const ADest: TBitmap);
var
  imgSource: TPNGImage;
begin
  imgSource := TPNGImage.Create();
  try
    imgSource.LoadFromStream(ASource);
    ADest.Assign(imgSource);
  finally
    FreeAndNil(imgSource);
  end;
end;

function ResizeImage(const ASource, ADest: String; const AWidth,
  AHeight: Integer; const ABackColor: TColor;
  const AType: TImageType = itUnknown): Boolean;
var
  fsSource: TFileStream;
  fsDest: TFileStream;
begin
  Result := False;
  fsSource := TFileStream.Create(ASource, fmOpenRead or fmShareDenyWrite);
  try
    fsDest := TFileStream.Create(ADest, fmCreate or fmShareExclusive);
    try
      Result := not Result; //hide compiler hint
      Result := ResizeImage(fsSource, fsDest, AWidth, AHeight, ABackColor, AType);
    finally
      FreeAndNil(fsDest);
    end;
  finally
    FreeAndNil(fsSource);
  end;
end;

function ResizeImage(const ASource, ADest: TStream; const AWidth,
  AHeight: Integer; const ABackColor: TColor;
  const AType: TImageType = itUnknown): Boolean;
var
  itImage: TImageType;
  ifImage: TImageInfo;
  bmpTemp: TBitmap;
  bmpSource: TBitmap32;
  bmpResized: TBitmap32;
  cBackColor: TColor32;
  rSource: TRect;
  rDest: TRect;
  dWFactor: Double;
  dHFactor: Double;
  dFactor: Double;
  iSrcWidth: Integer;
  iSrcHeight: Integer;
  iWidth: Integer;
  iHeight: Integer;
  jpgTemp: TJPEGImage;
begin
  Result := False;
  itImage := AType;
  if itImage = itUnknown then
  begin
    ifImage := GetImageInfo(ASource);
    itImage := ifImage.ImgType;
    if itImage = itUnknown then
      Exit;
  end;
  bmpTemp := TBitmap.Create();
  try
    case itImage of
      itBMP: bmpTemp.LoadFromStream(ASource);
      itGIF: GIFToBMP(ASource, bmpTemp);
      itJPG: JPGToBMP(ASource, bmpTemp);
      itPNG: PNGToBMP(ASource, bmpTemp);
    end;
    bmpSource := TBitmap32.Create();
    bmpResized := TBitmap32.Create();
    try
      cBackColor  := Color32(ABackColor);
      bmpSource.Assign(bmpTemp);
      bmpResized.Width := AWidth;
      bmpResized.Height := AHeight;
      bmpResized.Clear(cBackColor);
      iSrcWidth := bmpSource.Width;
      iSrcHeight := bmpSource.Height;
      iWidth := iSrcWidth;
      iHeight := iSrcHeight;
      with rSource do
      begin
        Left := 0;
        Top := 0;
        Right := iSrcWidth;
        Bottom := iSrcHeight;
      end;
      if (iWidth > AWidth) or (iHeight > AHeight) then
      begin
        dWFactor := AWidth / iWidth;
        dHFactor := AHeight / iHeight;
        if (dWFactor > dHFactor) then
          dFactor := dHFactor
        else
          dFactor := dWFactor;
        iWidth := Floor(iWidth * dFactor);
        iHeight := Floor(iHeight * dFactor);
      end;
      with rDest do
      begin
        Left := Floor((AWidth - iWidth) / 2);
        Top := Floor((AHeight - iHeight) / 2);
        Right := Left + iWidth;
        Bottom := Top + iHeight;
      end;
      bmpSource.Resampler := TKernelResampler.Create;
      TKernelResampler(bmpSource.Resampler).Kernel := TLanczosKernel.Create;
      bmpSource.DrawMode := dmOpaque;
      bmpResized.Draw(rDest, rSource, bmpSource);
      bmpTemp.Assign(bmpResized);
      jpgTemp := TJPEGImage.Create();
      jpgTemp.CompressionQuality := 80;
      try
        jpgTemp.Assign(bmpTemp);
        jpgTemp.SaveToStream(ADest);
        Result := True;
      finally
        FreeAndNil(jpgTemp);
      end;
    finally
      FreeAndNil(bmpResized);
      FreeAndNil(bmpSource);
    end;
  finally
    FreeAndNil(bmpTemp);
  end;
end;

end.

Notes:

¹⁾ I surely didn't code this myself, but do not know anymore where I got it from.
²⁾ Included in recent Delphi versions.
If compiling with more recent versions of RAD Studio/Delphi XE, remember to substitute char with ansichar for all char variable types otherwise the GetImageInfo will not work, and it will not resize the image. This is needed as the default char type is two bytes, and the function expects it to be single byte.

Solution 3:

I've often used the SmoothResize procedure from this page: http://www.swissdelphicenter.ch/torry/printcode.php?id=1896

The scaling is much better than the StretchDraw function.

Don't let the title fool you. The page demonstrates resizing JPGs, but the SmoothResize procedure itself uses bitmaps for resizing. Resizing PNGs could be done in a similar matter, but you will loose transparency if you use this procedure.

Solution 4:

Please see this simple example on how to resize an image using two TBitmap32 objects. The TBitmap32 is the best in terms of speed/image quality ratio.

It requires the https://github.com/graphics32 library.

uses 
  GR32, GR32_Resamplers;

procedure Resize(InputPicture: TBitmap; OutputImage: TImage; const DstWidth, DstHeigth: Integer);
var
  Src, Dst: TBitmap32;
begin
  Dst := nil;
  try
    Src := TBitmap32.Create;
    try
      Src.Assign(InputPicture);
      SetHighQualityStretchFilter(Src);
      Dst := TBitmap32.Create;
      Dst.SetSize(DstWidth, DstHeigth);
      Src.DrawTo(Dst, Rect(0, 0, DstWidth, DstHeigth), Rect(0, 0, Src.Width, Src.Height));
    finally
      FreeAndNil(Src);
    end;
    OutputImage.Assign(Dst);
  finally
    FreeAndNil(Dst);
  end;
end;

// If you need to set a highest quality resampler, use this helper routine to configure it
procedure SetHighQualityStretchFilter(B: TBitmap32);
var
  KR: TKernelResampler;
begin
  if not (B.Resampler is TKernelResampler) then
  begin
    KR := TKernelResampler.Create(B);
    KR.Kernel := TLanczosKernel.Create;
  end
  else
  begin
    KR := B.Resampler as TKernelResampler;
    if not (KR.Kernel is TLanczosKernel) then
    begin
      KR.Kernel.Free;
      KR.Kernel := TLanczosKernel.Create;
    end;
  end;
end;

How to resize a picture?

Solution 1:

Solution 2:

Solution 3:

Solution 4:

Related

Recent Posts