Bitmap Resizing

Das Problem bei einer größen Veränderung eines Bitmaps ist, dass immer Farben verloren gehen und die Qualität gemindert wird. Für das bloße Auge meist nicht zu sehen, doch das Bild hat nicht mehr die Qualität wie vorher. Hier sind zwei Funktionen, die unabhängige Eigenschaften besitzen. Das eine ist sehr schnell, doch mindert die Qualität sehr und das andere hat eine Berechnungszeit, die die Pixel genauer setzt und für eine bessere Bildqualität sorgt. 

Langsam aber Hohe Qualität

private
{ Private declarations }
procedure ResizeBitmap(imgo, imgd: TBitmap; nw, nh: Integer);
    
//

procedure TForm1.ResizeBitmap(imgo, imgd: TBitmap; nw, nh: Integer);
var
  xini, xfi, yini, yfi, saltx, salty: single;
  x, y, px, py, tpix: integer; PixelColor: TColor; r, g, b: longint;

  function MyRound(const X: Double): Integer;
  begin
    Result := Trunc(x);
    if Frac(x) >= 1.0 then
      if x >= 0 then Result := Result + 1
      else
        Result := Result - 1;
  end;

begin
  imgd.Width  := nw; imgd.Height := nh;
  saltx := imgo.Width / nw; salty := imgo.Height / nh;
  yfi := 0;  for y := 0 to nh - 1 do
  begin
  Application.ProcessMessages;
    yini := yfi;
    yfi  := yini + salty;
    if yfi >= imgo.Height then yfi := imgo.Height - 1;
    xfi := 0;
    for x := 0 to nw - 1 do
    begin
      xini := xfi; xfi  := xini + saltx;
      if xfi >= imgo.Width then xfi := imgo.Width - 1;
      r := 0; g := 0; b := 0; tpix := 0;
      for py := MyRound(yini) to MyRound(yfi) do
      begin  for px := MyRound(xini) to MyRound(xfi) do
        begin
          Inc(tpix);
          PixelColor := ColorToRGB(imgo.Canvas.Pixels[px, py]);
          r := r + GetRValue(PixelColor);
          g := g + GetGValue(PixelColor);
          b := b + GetBValue(PixelColor);
        end;
      end;
      imgd.Canvas.Pixels[x, y] := rgb(MyRound(r / tpix), 
                           MyRound(g / tpix), MyRound(b / tpix) );
    end;
  end;
  Screen.Cursor := crDefault;
end;

Beispiel :

procedure TForm1.Button1Click(Sender: TObject);
var bmp, bmpRes : TBitmap;
begin
  Screen.Cursor := crHourGlass;
  bmp := TBitmap.Create;
  bmpRes := TBitmap.Create;
  try
    bmp.Assign(Image1.Picture.Bitmap);
    ResizeBitmap(bmp, bmpRes, 800, 600);
    Image1.Picture.Bitmap.Assign(bmpRes);
  finally
  bmp.Free;
  bmpRes.Free;
  end;
end;

Sehr schnell aber schlechte Qualität

procedure ResizeBmp(Dest: TBitmap; const WMax, HMax: Word);
type
  pRGBArray = ^TRGBArray;
  TRGBArray = array[Word] of TRGBTriple;
var
  TBmp: TBitmap;
  DstGap: Integer;
  WNew, HNew: Integer;
  X, Y, T3: Integer;
  Z1, Z2, IZ2: Integer;
  W1, W2, W3, W4: Integer;
  XP, XP2, YP, YP2: Integer;
  SrcLine1, SrcLine2, DstLine: pRGBArray;
Begin
  TBmp := TBitmap.Create;
  try
    try
      WNew := (Dest.Width * HMax) div Dest.Height;
      HNew := (WMax * Dest.Height) div Dest.Width;
      if (WMax < WNew) then
      begin
        TBmp.Width := WMax;
        TBmp.Height := HNew;
      end else
      begin
        TBmp.Width := WNew;
        TBmp.Height := HMax;
      end;
      Dest.PixelFormat := pf24Bit;
      TBmp.PixelFormat := pf24bit;
      DstLine := TBmp.ScanLine[0];
      DstGap  := Integer(TBmp.ScanLine[1]) - Integer(DstLine);
      XP2 := MulDiv(Pred(Dest.Width), $10000, TBmp.Width);
      YP2 := MulDiv(Pred(Dest.Height), $10000, TBmp.Height);
      YP  := 0;
      for Y := 0 to Pred(TBmp.Height) do
      begin
        XP := 0;
        SrcLine1 := Dest.ScanLine[YP shr 16];
        if (YP shr 16 < Pred(Dest.Height))
          then SrcLine2 := Dest.ScanLine[Succ(YP shr 16)]
          else SrcLine2 := Dest.ScanLine[YP shr 16];
        Z2  := Succ(YP and $FFFF);
        IZ2 := Succ((not YP) and $FFFF);
        for X := 0 to Pred(TBmp.Width) do
        begin
          T3 := XP shr 16;
          Z1 := XP and $FFFF;
          W2 := MulDiv(Z1, IZ2, $10000);
          W1 := IZ2 - W2;
          W4 := MulDiv(Z1, Z2, $10000);
          W3 := Z2 - W4;
          DstLine[X].rgbtRed   := (SrcLine1[T3].rgbtRed   * W1 + SrcLine1[T3 + 1].rgbtRed   * W2 + SrcLine2[T3].rgbtRed   * W3 + SrcLine2[T3 + 1].rgbtRed   * W4) shr 16;
          DstLine[X].rgbtGreen := (SrcLine1[T3].rgbtGreen * W1 + SrcLine1[T3 + 1].rgbtGreen * W2 + SrcLine2[T3].rgbtGreen * W3 + SrcLine2[T3 + 1].rgbtGreen * W4) shr 16;
          DstLine[X].rgbtBlue  := (SrcLine1[T3].rgbtBlue  * W1 + SrcLine1[T3 + 1].rgbtBlue  * W2 + SrcLine2[T3].rgbtBlue  * W3 + SrcLine2[T3 + 1].rgbtBlue  * W4) shr 16;
          Inc(XP, XP2);
        end;
        Inc(YP, YP2);
        DstLine := pRGBArray(Integer(DstLine) + DstGap);
      end;
      Dest.Assign(TBmp);
    except
    end;
  finally
    TBmp.Free;
  end;
end;

Beispiel :

procedure TForm1.Button2Click(Sender: TObject);
begin
  ResizeBmp(Image1.Picture.Bitmap, 1000,1000);
end;

Es gibt noch etliche weitere Funktionen, doch die heben sich nicht von den beiden hier dargestellt besonders ab.