Scalering af bitmap

Hvad med dette?

www.swissdelphicenter.ch/torry/showcode.php?id=1806

Ja.. det virker godt. Men jeg har faktisk brug for at skalere ned til en givet størrelse, fx 120x160px. Min fejl, spørgsmålet var ikke formuleret ordentligt...

Nej.. du får sgu halv point.. tror godt jeg kan bruge det alligevel. Så må jeg jo bare arbejde lidt videre på det.

hvis du lige lægger et "svar"

Der er flere måder at gøre det på.

Den enkle er stretchDraw, men giver ofte et kornet resultat.
Dest.Canvas.StretchDraw(Rect(0,0,Dest.Width,Dest.Height),Src);

En anden måder er at bruge denne procedure : SmoothResize.

I begge tilfælde skal man bruge to TBitmap: Scr og Dest.
Src er det oprindelige bitmap. Dest er det scalerede (resizede) bitmap.
Man angiver selv størrelsen af dest før proceduren kaldes.
F.eks.

Dest.Height := 300;
Dest.Width := 400;

procedure SmoothResize(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 <= dest.Width) and (src.Height <= dest.Height) 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;
  try
  xscale := 1 / (w / src.Width);
  yscale := 1 / (h / src.Height);
  except on exception do end;
  // 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);  /// her opstår en fejl:  division by zero ????????????????
      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;

All right, sä held og lykke med det..

Jeg valgte at afvise dit svar eht, idet det ikke virker iflg. kommentaren:
      iRatio := 65535 div (dx * dy);  /// her opstår en fejl:  division by zero ????????????????

Det er OK at du afviser mit svar, men du skulle nu alligevel kigge lidt nærmere på proceduren. Den tegner fine og skarpe thumbnails.

Jeg bruger proceduren som den står i et af mine programmer, uden at der opstår fejl.
Kommentaren jeg skrev vistnok engang, mens jeg tilrettede koden. Den burde være slettet.