Mega Code Archive
Fast Quality reduction of Bitmap size using the Scanline system colors
<![CDATA[
Title: Fast Quality reduction of Bitmap size using the Scanline system colors.
Question: Fast Quality reduction of Bitmap size using the Scanline system colors.
Answer:
function Shrink(PBitmap: TBitmap; Scale: Double): TBitmap;
var
LBitmap: TBitmap;
DX, DY: Integer;
SX, SY: Integer;
SBox: TRect;
DLine: PByteArray;
SLine: PByteArray;
ScaleF: Double;
PixCount: Integer;
LR,LG,LB: Integer;
LSX, LDX: Integer;
begin
Result := nil;
if not assigned(PBitmap)
or (Scale 1)
or (Scale or (PBitmap.Width or (PBitmap.Height
if Scale = 1 then
begin
Result := PBitmap;
Exit;
end;
if Scale = 0 then
begin
PBitmap.Width := 0;
PBitmap.Height := 0;
Result := PBitmap;
end;
ScaleF := 1 / Scale;
LBitmap := TBitmap.Create;
LBitmap.PixelFormat := pf24Bit;
LBitmap.Assign(PBitmap);
PBitmap.Width := round(LBitmap.Width * Scale);
PBitmap.Height := round(LBitmap.Height * Scale);
file://for each pixel in PBitmap do...
for DY := 0 to PBitmap.Height - 1 do
begin
DLine := PBitmap.ScanLine[DY];
for DX := 0 to PBitmap.Width - 1 do
begin
SBox.Left := trunc(DX * ScaleF);
SBox.Top := trunc(DY * ScaleF);
SBox.Right := trunc((DX + 1) * ScaleF);
SBox.Bottom := trunc((DY + 1) * ScaleF);
LR := 0;
LG := 0;
LB := 0;
PixCount := 0;
for SY := SBox.Top to SBox.Bottom - 1 do
begin
SLine := LBitmap.ScanLine[SY];
for SX := SBox.Left to SBox.Right - 1 do
begin
LSX := SX * 3;
inc(LR,SLine[LSX]);
inc(LG,SLine[LSX + 1]);
inc(LB,SLine[LSX + 2]);
inc(PixCount);
end;
end;
LDX := DX * 3;
DLine[LDX] := LR div PixCount;
DLine[LDX + 1] := LG div PixCount;
DLine[LDX + 2] := LB div PixCount;
LR := 0;
LG := 0;
LB := 0;
end;
end;
LBitmap.Free;
result := PBitmap;
end;
]]>