How to resize a picture? - image

Question

I have image (500x500) but I need to resize it to 200x200 and paint it on TImage. How to achieve such result?
NoteI know about Stretch property in TImage, but I want to resize the image programmatically.

Answer 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?)

Answer 2

Great usability and picture quality offers the ResizeImage function(s) from the unit 1) below. The code depends on Graphics32, GIFImage 2) and PNGImage 2).
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:
1) I surely didn't code this myself, but do not know anymore where I got it from.
2) 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.

Answer 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.

Answer 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;

Answer 5

I have done quite some extensive testing (10 algorithms/libraries) in this direction. I only mention the first three.
If you are lazy to read, skip to MY conclusions
:)
JanFX library
Now incorporated into the fat Jedi distribution. FORTUNATELY you can extract this file from Jedi without having to drag the whole mammoth into your project.
It gives a very nice smoothing (not as good as Graphics32 but good enough) but much, much faster.
Note: The JanFX.pas in Jedi is bugged: does not work when range checking is on. You need to define {$R-} before the code. That's it. The guys at Jedi entered this bug because they ALWAYS compile with range checking off.
JanFx.SmoothResize(SrcBMP, DstBMP);
Graphics32 lib
Super good output quality.
But if all you need is a resampler, it might be overkill to use the entire Graphics32 lib. JanFx is much smaller and portable. Graphics32 will give you slightly better results, BUT the processing times are about 10x higher!
StretchBlt
If you don't want to involve external libraries, look into StretchBlt.
This will not give you the best results as Graphics32, but it is ridiculously faster, compared with Graphics32.
(see code below)
Conclusion:
StretchBlt is my final choice for my programs, being the best trade between the output quality and speed. It does a good job not only in downsampling but also in upsampling.
{-------------------------------------------------------------------------------------------------------------
Uses MS Windows StretchBlt
BEST (see tester)
Zoom: In/Out
Keep aspect ration: No
Stretch provided in: pixels
Resize down: VERY smooth. Better than JanFX.SmoothResize.
Resize up: better (sharper) than JanFX.SmoothResize
Time: similar to JanFx
BitBlt only does copy. NO STRETCH
https://msdn.microsoft.com/en-us/library/windows/desktop/dd162950(v=vs.85).aspx
-------------------------------------------------------------------------------------------------------------}
function StretchF(BMP: TBitmap; OutWidth, OutHeight: Integer): TBitmap;
begin
if (BMP.Width < 12) OR (BMP.Height< 12) then
begin
ShowMessage('Cannot stretch images under 12 pixels!'); { 'WinStretchBltF' will crash if the image size is too small (below 10 pixels)}
EXIT(NIL);
end;
Result:= TBitmap.Create;
TRY
Result.PixelFormat:= BMP.PixelFormat; { Make sure we use the same pixel format as the original image }
SetLargeSize(Result, OutWidth, OutHeight);
SetStretchBltMode(Result.Canvas.Handle, HALFTONE);
SetBrushOrgEx (Result.Canvas.Handle, 0,0, NIL);
StretchBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height, BMP.Canvas.Handle, 0, 0, BMP.Width, BMP.Height, SRCCOPY);
FINALLY
FreeAndNil(Result);
RAISE;
END;
end;

Answer 6

for any type of images, you can use this:
img := TIMage.create(nil);
img.picture.loadfromfile('any_file_type');
Result:= TBitmap.Create;
result.Width := newWidth;
result.Height := newHeight;
Result.Canvas.Draw(0,0,img.Picture.Graphic);