Как сделать Thumbnail?
01.01.2007
{ Here is the routine I use in my thumbnail component and I belive it is quite fast. A tip to gain faster loading of jpegs is to use the TJpegScale.Scale property. You can gain a lot by using this correct. This routine can only downscale images no upscaling is supported and you must correctly set the dest image size. The src.image will be scaled to fit in dest bitmap. } const FThumbSize = 150; //Speed up by Renate Schaaf, Armido, Gary Williams... procedure MakeThumbNail(src, dest: tBitmap); type PRGB24 = ^TRGB24; TRGB24 = packed record B: Byte; G: Byte; R: Byte; end; var x, y, ix, iy: integer; x1, x2, x3: integer; xscale, yscale: single; iRed, iGrn, iBlu, iRatio: Longword; p, c1, c2, c3, c4, c5: tRGB24; pt, pt1: pRGB24; iSrc, iDst, s1: integer; i, j, r, g, b, tmpY: integer; RowDest, RowSource, RowSourceStart: integer; w, h: integer; dxmin, dymin: integer; ny1, ny2, ny3: integer; dx, dy: integer; lutX, lutY: array of integer; begin if src.PixelFormat <> pf24bit then src.PixelFormat := pf24bit; if dest.PixelFormat <> pf24bit then dest.PixelFormat := pf24bit; w := Dest.Width; h := Dest.Height; if (src.Width <= FThumbSize) and (src.Height <= FThumbSize) then begin dest.Assign(src); exit; end; iDst := (w * 24 + 31) and not 31; iDst := iDst div 8; //BytesPerScanline iSrc := (Src.Width * 24 + 31) and not 31; iSrc := iSrc div 8; xscale := 1 / (w / src.Width); yscale := 1 / (h / src.Height); // X lookup table SetLength(lutX, w); x1 := 0; x2 := trunc(xscale); for x := 0 to w - 1 do begin lutX[x] := x2 - x1; x1 := x2; x2 := trunc((x + 2) * xscale); end; // Y lookup table SetLength(lutY, h); x1 := 0; x2 := trunc(yscale); for x := 0 to h - 1 do begin lutY[x] := x2 - x1; x1 := x2; x2 := trunc((x + 2) * yscale); end; dec(w); dec(h); RowDest := integer(Dest.Scanline[0]); RowSourceStart := integer(Src.Scanline[0]); RowSource := RowSourceStart; for y := 0 to h do begin dy := lutY[y]; x1 := 0; x3 := 0; for x := 0 to w do begin dx:= lutX[x]; iRed:= 0; iGrn:= 0; iBlu:= 0; RowSource := RowSourceStart; for iy := 1 to dy do begin pt := PRGB24(RowSource + x1); for ix := 1 to dx do begin iRed := iRed + pt.R; iGrn := iGrn + pt.G; iBlu := iBlu + pt.B; inc(pt); end; RowSource := RowSource - iSrc; end; iRatio := 65535 div (dx * dy); pt1 := PRGB24(RowDest + x3); pt1.R := (iRed * iRatio) shr 16; pt1.G := (iGrn * iRatio) shr 16; pt1.B := (iBlu * iRatio) shr 16; x1 := x1 + 3 * dx; inc(x3,3); end; RowDest := RowDest - iDst; RowSourceStart := RowSource; end; if dest.Height < 3 then exit; // Sharpening... s1 := integer(dest.ScanLine[0]); iDst := integer(dest.ScanLine[1]) - s1; ny1 := Integer(s1); ny2 := ny1 + iDst; ny3 := ny2 + iDst; for y := 1 to dest.Height - 2 do begin for x := 0 to dest.Width - 3 do begin x1 := x * 3; x2 := x1 + 3; x3 := x1 + 6; c1 := pRGB24(ny1 + x1)^; c2 := pRGB24(ny1 + x3)^; c3 := pRGB24(ny2 + x2)^; c4 := pRGB24(ny3 + x1)^; c5 := pRGB24(ny3 + x3)^; r := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) div -8; g := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) div -8; b := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) div -8; if r < 0 then r := 0 else if r > 255 then r := 255; if g < 0 then g := 0 else if g > 255 then g := 255; if b < 0 then b := 0 else if b > 255 then b := 255; pt1 := pRGB24(ny2 + x2); pt1.R := r; pt1.G := g; pt1.B := b; end; inc(ny1, iDst); inc(ny2, iDst); inc(ny3, iDst); end; end;
Взято с сайта https://www.swissdelphicenter.ch/en/tipsindex.php