Create a ScanLine implementation of Stretchblt (Views: 28)
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. |