Необходимо уменьшить масштаб полученного снимка с минимальными потерями качества.
Результат: масштаб был уменьшен с помощью функции ResizeBitmap - качество изображения изменилось с худшим результатом:
Качество изображения без функции ResizeBitmap :
Прошу помочь разобраться с уменьшением масштаба изображения с минимальными потерями в качества.
Результат: масштаб был уменьшен с помощью функции ResizeBitmap - качество изображения изменилось с худшим результатом:
Качество изображения без функции ResizeBitmap :
Прошу помочь разобраться с уменьшением масштаба изображения с минимальными потерями в качества.
Код:
uses Jpeg;
function ResizeBitmap(BmpIn : TBitmap; NewWidth, NewHeight : Integer) : TBitmap;
begin
Result := TBitmap.Create;
try
Result.Width := NewWidth;
Result.Height := NewHeight;
Result.PixelFormat := BmpIn.PixelFormat;
Result.Canvas.StretchDraw(Rect(0, 0, Result.Width, Result.Height), BmpIn);
except
Result.Free;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
JpegIm: TJpegImage;
bm: TBitMap;
ScrJpg : String;
begin
ScrJpg := 'screenshot.jpg';
DeleteFile(ScrJpg);
bm := TBitMap.Create;
bm.Width := Screen.Width;
bm.Height := Screen.Height;
BitBlt(bm.Canvas.Handle, 0, 0, bm.Width, bm.Height, GetDC(0), 0, 0, SRCCOPY);
bm := ResizeBitmap(bm, 1200, 674);
JpegIm := TJpegImage.Create;
JpegIm.Assign(bm);
JpegIm.CompressionQuality := 90;
JpegIm.Compress;
JpegIm.SaveToFile(ScrJpg);
bm.Destroy;
JpegIm.Destroy;
Form1.Close;
end;