Изменение размера
Материал из DRKB
Функция изменяет размер битмапа, вычисляя средний цвет прямоугольника из пикселей и записывая в пиксель или прямоугольник пикселей внутри другого битмапа (приемника). Получается глядкое изображение без искажений, в отличие от стандартного метода StretchDraw.
Наверное, у этого алгоритма есть своё название, не знаю..
Ну и, есть что оптимизировать..
procedure TFormConvertir.ResizeBitmap(imgo, imgd: TBitmap; nw, nh: Integer);
var
xini, xfi, yini, yfi, saltx, salty: Single;
x, y, px, py, tpix: Integer;
PixelColor: TColor;
r, g, b: LongInt;
function MyRound(const X: Double): Integer;
begin
Result := Trunc(x);
if Frac(x) >= 0.5 then
if x >= 0 then
Result := Result + 1
else
Result := Result - 1;
// Result := Trunc(X + (-2 * Ord(X < 0) + 1) * 0.5);
end;
begin
// Установка размера результата
imgd.Width := nw;
imgd.Height := nh;
// Вычисляем ширину и высоту каждого прямоугольника исходного битмапа
saltx := imgo.Width / nw;
salty := imgo.Height / nh;
yfi := 0;
for y := 0 to nh - 1 do
begin
// Устанавливаем начальную и конечную координату Y прямоугольника
yini := yfi;
yfi := yini + salty;
if yfi >= imgo.Height then yfi := imgo.Height - 1;
xfi := 0;
for x := 0 to nw - 1 do
begin
// Устанавливаем начальную и конечную координату X прямоугольника
xini := xfi;
xfi := xini + saltx;
if xfi >= imgo.Width then xfi := imgo.Width - 1;
// Вычисление среднего цвета прямоугольника
r := 0;
g := 0;
b := 0;
tpix := 0;
for py := MyRound(yini) to MyRound(yfi) do
begin
for px := MyRound(xini) to MyRound(xfi) do
begin
Inc(tpix);
PixelColor := ColorToRGB(imgo.Canvas.Pixels[px, py]);
r := r + GetRValue(PixelColor);
g := g + GetGValue(PixelColor);
b := b + GetBValue(PixelColor);
end;
end;
// Рисуем получившийся пиксель
imgd.Canvas.Pixels[x, y] :=
RGB(MyRound(r / tpix), MyRound(g / tpix), MyRound(b / tpix));
end;
end;
end;
ID: 03833