Приведенный в статье "Изменение разрешения изображения" алгоритм изменения разрешения изображения рабочий, только, как оказалось, очень медленный. Я сразу подумал, что это из-за использования мной режима масштабирования изображения HALFTONE. Но, даже при использовании режима COLORONCOLOR, моя процедура в 3-4 раза медленнее стандартного метода Canvas.StretchDraw!
Пройдя под отладкой от вызова Canvas.StretchDraw до TBitmap.Draw я нашел, что причиной такой разницы в скорости работы является получение хэндла Canvas. У TBitmap.Draw он читается напрямую - ACanvas.FHandle, а у меня через свойство Canvas.Handle. Геттер этого свойства вызывает метод TCanvas.RequiredState, в котором он пересоздает хэндл Canvas используя метод TBitmapCanvas.CreateHandle. Итак, чтобы решить проблему с быстродействием надо избавиться от повторного создания хэндла, а для этого необходимо получить доступ к приватному свойству TCanvas.FHandle:
В результате всех моих изысканий окончательный вариант модуля для изменения разрешения изображения у меня получился такой:
P.S. Кто-то еще сомневается в пользе возможности доступа к приватным членам класса в Delphi?
Пройдя под отладкой от вызова Canvas.StretchDraw до TBitmap.Draw я нашел, что причиной такой разницы в скорости работы является получение хэндла Canvas. У TBitmap.Draw он читается напрямую - ACanvas.FHandle, а у меня через свойство Canvas.Handle. Геттер этого свойства вызывает метод TCanvas.RequiredState, в котором он пересоздает хэндл Canvas используя метод TBitmapCanvas.CreateHandle. Итак, чтобы решить проблему с быстродействием надо избавиться от повторного создания хэндла, а для этого необходимо получить доступ к приватному свойству TCanvas.FHandle:
type
TCanvas = class(TCustomCanvas)
private
FHandle: HDC;
Это свойство видят и используют методы классов, которые расположены в модуле Vcl.Graphics. От остальных программистов оно скрыто за модификатором доступа private. Что бы восстановить справедливость, воспользуемся одним из способов, которые я описал в статье "Доступ к private членам класса". Я выбрал способ, которого разработчики Delphi пытались нас лишить в Delphi 10.1 Berlin, но на наше счастье они допустили баг и оставили лазейку - создадим class helper для TCanvas:type
TCanvasHelper = class helper for TCanvas
function GetFHandle: HDC;
end;
implementation
{ TCanvasHelper }
function TCanvasHelper.GetFHandle: HDC;
begin
with Self do
begin
if FHandle = 0 then
RequiredState([csHandleValid..csBrushValid]);
Result := FHandle;
end;
end;
Получим в процедуре ScaleJpeg хэндлы используя функцию GetFHandle из helper'а:procedure ScaleJpeg(jpg: TJPEGImage; const NewWidth, NewHeight: Integer;
const StretchMode: Integer = COLORONCOLOR);
var
bmp: Vcl.Graphics.TBitmap;
fScale: Double;
PrevPt: TPoint;
hBMP, hJPG: HDC;
begin
fScale := Min(NewWidth / jpg.Width, NewHeight / jpg.Height);
bmp := Vcl.Graphics.TBitmap.Create;
try
bmp.SetSize(Round(jpg.Width * fScale), Round(jpg.Height * fScale));
hBMP := bmp.Canvas.GetFHandle;
hJPG := jpg.Canvas.GetFHandle;
GetBrushOrgEx(hBMP, PrevPt);
SetStretchBltMode(hBMP, StretchMode);
SetBrushOrgEx(hBMP, PrevPt.x, PrevPt.y, @PrevPt);
StretchBlt(hBMP, 0, 0, bmp.Width, bmp.Height,
hJPG, 0, 0, jpg.Width, jpg.Height,
SRCCOPY);
jpg.Assign(bmp);
finally
bmp.Free;
end;
end;
Теперь масштабирование тестового изображения большого разрешения моей процедурой в режиме COLORONCOLOR работает с такой же скоростью, как у стандартного метода Canvas.StretchDraw.В результате всех моих изысканий окончательный вариант модуля для изменения разрешения изображения у меня получился такой:
unit ahGraphicsHelpers;
interface
uses
System.Classes, System.SysUtils, System.Math,
Vcl.Graphics, Vcl.Imaging.jpeg, WinAPI.Windows;
type
TCanvasHelper = class helper for TCanvas
function GetFHandle: HDC;
end;
TJPEGImageHelper = class helper for TJPEGImage
procedure Resize(const NewWidth, NewHeight: Integer;
const StretchMode: Integer = COLORONCOLOR);
end;
implementation
{ TCanvasHelper }
function TCanvasHelper.GetFHandle: HDC;
begin
with Self do
begin
if FHandle = 0 then
RequiredState([csHandleValid..csBrushValid]);
Result := FHandle;
end;
end;
{ TJPEGImageHelper }
procedure TJPEGImageHelper.Resize(const NewWidth, NewHeight,
StretchMode: Integer);
var
bmp: Vcl.Graphics.TBitmap;
fScale: Double;
PrevPt: TPoint;
hBMP, hJPG: HDC;
begin
if (NewWidth <> Width) or (NewHeight <> Height) then
begin
fScale := Min(NewWidth / Width, NewHeight / Height);
bmp := Vcl.Graphics.TBitmap.Create;
try
bmp.SetSize(Round(Width * fScale), Round(Height * fScale));
hBMP := bmp.Canvas.GetFHandle;
hJPG := Canvas.GetFHandle;
GetBrushOrgEx(hBMP, PrevPt);
SetStretchBltMode(hBMP, StretchMode);
SetBrushOrgEx(hBMP, PrevPt.x, PrevPt.y, @PrevPt);
StretchBlt(hBMP, 0, 0, bmp.Width, bmp.Height,
hJPG, 0, 0, Width, Height, SRCCOPY);
Assign(bmp);
finally
bmp.Free;
end;
end;
end;
end.
Пример использования:var jpg: TJPEGImage; begin ... jpg.Resize(1000, 1000, HALFTONE);
P.S. Кто-то еще сомневается в пользе возможности доступа к приватным членам класса в Delphi?
Комментариев нет:
Отправить комментарий