1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:

procedure DecreaseSize(BM:TBitmap; Fract:byte);
type
  PRGBQuads=^TRGBQuads;
  TRGBQuads=packed array[0..0]of TRGBQuad;

var ln,cl,x,y:integer;
    l:array of PRGBQuads;
    r,g,b,cnt:integer;
    current:PRGBQuad;
begin
  if Fract<=1 then exit;
  if BM.PixelFormat<>pf32Bit then exit;
  BM.Width:= ceil(BM.Width / Fract)*Fract;
  BM.Height:= ceil(BM.Height / Fract)*Fract;
  SetLength(l,Fract);
  cnt:= Fract*Fract;
  ln:= 0;
  while ln<BM.Height do begin
    current:= BM.ScanLine[ln div Fract];
    for y:= 0 to Fract-1 do
      l[y]:= BM.ScanLine[ln+y];
    cl:= 0;
    while cl<BM.Width do begin
      r:=0; g:= 0; b:= 0;
      for x:= cl to cl+Fract-1 do
        for y:= 0 to Fract-1 do begin
          inc(r,l[y,x].rgbRed);
          inc(g,l[y,x].rgbGreen);
          inc(b,l[y,x].rgbBlue);
        end;
      current^.rgbRed:= r div cnt;
      current^.rgbGreen:= g div cnt;
      Current^.rgbBlue:=b div cnt;
      inc(current);
      inc(cl,Fract);
    end;
    inc(ln,Fract);
  end;
  BM.Width:= BM.Width div Fract;
  BM.Height:= BM.Height div Fract;
end;