Create a ScanLine implementation of Stretchblt

Problem/Question/Abstract:

How to create a ScanLine implementation of Stretchblt

Answer:

I'm using this routine for animated zooms, so I took special care to keep the stretch centered. In this scenario the simple stretch makes sense and improves performance. For thumbnailing, be aware that when you make a thumbnail from a bmp file from disk, then most of the time is spent on file I/O, the resampling time compared to that is peanuts, same goes for a jpeg, only for those the decoding is what takes long.

unit DeleteScans;

interface

uses
Windows, Graphics;

procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
{ScanLine implementation of Stretchblt/Delete_Scans. About twice as fast.
Stretches Src to Dest, rs is source rect, rd is dest. rect. The stretch is centered,
i.e the center of rs is mapped to the center of rd. Src, Dest are assumed to be bottom up}

implementation

uses
Classes, Math;

type
TRGBArray = array[0..64000] of TRGBTriple;
PRGBArray = ^TRGBArray;
TQuadArray = array[0..64000] of TRGBQuad;
PQuadArray = ^TQuadArray;

procedure DeleteScansRect(Src, Dest: TBitmap; rs, rd: TRect);
var
xsteps, ysteps: array of Integer;
intscale: Integer;
i, x, y, x1, x2, bitspp, bytespp: Integer;
ts, td: PByte;
bs, bd, WS, hs, w, h: Integer;
Rows, rowd: PByte;
j, c: Integer;
pf: TPixelFormat;
xshift, yshift: Integer;
begin
WS := rs.Right - rs.Left;
hs := rs.Bottom - rs.Top;
w := rd.Right - rd.Left;
h := rd.Bottom - rd.Top;
pf := Src.PixelFormat;
if (pf <> pf32Bit) and (pf <> pf24bit) then
begin
pf := pf24bit;
Src.PixelFormat := pf;
end;
Dest.PixelFormat := pf;
if not (((w <= WS) and (h <= hs)) or ((w >= WS) and (h >= hs))) then
{We do not handle a mix of up-and downscaling, using threadsafe StretchBlt instead}
begin
Src.Canvas.Lock;
Dest.Canvas.Lock;
try
SetStretchBltMode(Dest.Canvas.Handle, STRETCH_DELETESCANS);
StretchBlt(Dest.Canvas.Handle, rd.Left, rd.Top, w, h, Src.Canvas.Handle,
rs.Left, rs.Top, WS, hs, SRCCopy);
finally
Dest.Canvas.Unlock;
Src.Canvas.Unlock;
end;
exit;
end;
if pf = pf24bit then
begin
bitspp := 24;
bytespp := 3;
end
else
begin
bitspp := 32;
bytespp := 4;
end;
bs := (Src.Width * bitspp + 31) and not 31;
bs := bs div 8; {BytesPerScanline Source}
bd := (Dest.Width * bitspp + 31) and not 31;
bd := bd div 8; {BytesPerScanline Dest}
if w < WS then {downsample}
begin
{first make arrays of the skipsteps}
SetLength(xsteps, w);
SetLength(ysteps, h);
intscale := round(WS / w * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to w - 1 do
begin
xsteps[i] := (x2 - x1) * bytespp;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if i = w - 2 then
c := x1;
end;
xshift := min(max((WS - c) div 2, -rs.Left), Src.Width - rs.Right);
intscale := round(hs / h * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to h - 1 do
begin
ysteps[i] := (x2 - x1) * bs;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if i = h - 2 then
c := x1;
end;
yshift := min(max((hs - c) div 2, -rs.Top), Src.Height - rs.Bottom);
if pf = pf24bit then
begin
Rows := @PRGBArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to h - 1 do
begin
ts := Rows;
td := rowd;
for x := 0 to w - 1 do
begin
pRGBTriple(td)^ := pRGBTriple(ts)^;
inc(td, bytespp);
inc(ts, xsteps[x]);
end;
Dec(rowd, bd);
Dec(Rows, ysteps[y]);
end;
end
else
begin
Rows := @PQuadArray(Src.Scanline[rs.Top + yshift])^[rs.Left + xshift];
rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to h - 1 do
begin
ts := Rows;
td := rowd;
for x := 0 to w - 1 do
begin
pRGBQuad(td)^ := pRGBQuad(ts)^;
inc(td, bytespp);
inc(ts, xsteps[x]);
end;
Dec(rowd, bd);
Dec(Rows, ysteps[y]);
end;
end;
end
else
begin
{first make arrays of the steps of uniform pixels}
SetLength(xsteps, WS);
SetLength(ysteps, hs);
intscale := round(w / WS * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to WS - 1 do
begin
xsteps[i] := x2 - x1;
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if x2 > w then
x2 := w;
if i = WS - 1 then
c := x1;
end;
if c < w then {>is now not possible}
begin
xshift := (w - c) div 2;
yshift := w - c - xshift;
xsteps[WS - 1] := xsteps[WS - 1] + xshift;
xsteps[0] := xsteps[0] + yshift;
end;
intscale := round(h / hs * $10000);
x1 := 0;
x2 := (intscale + $7FFF) shr 16;
c := 0;
for i := 0 to hs - 1 do
begin
ysteps[i] := (x2 - x1);
x1 := x2;
x2 := ((i + 2) * intscale + $7FFF) shr 16;
if x2 > h then
x2 := h;
if i = hs - 1 then
c := x1;
end;
if c < h then
begin
yshift := (h - c) div 2;
ysteps[hs - 1] := ysteps[hs - 1] + yshift;
yshift := h - c - yshift;
ysteps[0] := ysteps[0] + yshift;
end;
if pf = pf24bit then
begin
Rows := @PRGBArray(Src.Scanline[rs.Top])^[rs.Left];
rowd := @PRGBArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to hs - 1 do
begin
for j := 1 to ysteps[y] do
begin
ts := Rows;
td := rowd;
for x := 0 to WS - 1 do
begin
for i := 1 to xsteps[x] do
begin
pRGBTriple(td)^ := pRGBTriple(ts)^;
inc(td, bytespp);
end;
inc(ts, bytespp);
end;
Dec(rowd, bd);
end;
Dec(Rows, bs);
end;
end
else
begin
Rows := @PQuadArray(Src.Scanline[rs.Top])^[rs.Left];
rowd := @PQuadArray(Dest.Scanline[rd.Top])^[rd.Left];
for y := 0 to hs - 1 do
begin
for j := 1 to ysteps[y] do
begin
ts := Rows;
td := rowd;
for x := 0 to WS - 1 do
begin
for i := 1 to xsteps[x] do
begin
pRGBQuad(td)^ := pRGBQuad(ts)^;
inc(td, bytespp);
end;
inc(ts, bytespp);
end;
Dec(rowd, bd);
end;
Dec(Rows, bs);
end;
end;
end;
end;

end.