Tips (1541)

Tip Rating (13):

type
  PBitmap = ^TBitmap;
  TLine = array[0..MaxInt div SizeOf(TRGBQUAD) - 1] of TRGBQUAD;
  PLine = ^TLine;


function ResampleSubBitmap(Bitmap: TBitmap; XPos, YPos, Width, Height: Integer): TRGBQuad;
var
  r, g, b: Cardinal;
  Line: PLine;
  x, y, z: Integer;
begin
  z := (Width * Height);
  r := 0;
  g := 0;
  b := 0;

  //Grenzüberschreitungen abfangen
  if (YPos + Height) >= Bitmap.Height then Height := (Bitmap.Height - YPos) - 1;
  if (XPos + Width) >= Bitmap.Width then Width := (Bitmap.Width - XPos) - 1;

  //Für jedes Pixel die Werte lesen und aufaddieren
  for y := YPos to YPos + Height do
  begin
    Line := Bitmap.ScanLine[y];
    for x := XPos to XPos + Width do
    begin
      r := r + Line[x].rgbRed;
      g := g + Line[x].rgbGreen;
      b := b + Line[x].rgbBlue;
      Inc(z);
    end;
  end;

  if (z = 0) then z := 1;
  //Mittelwert bestimmen und kleine Helligkeitskorrektur
  r := Round((r / z) * 1.4);
  if (r > 255) then r := 255;
  g := Round((g / z) * 1.4);
  if (g > 255) then g := 255;
  b := Round((b / z) * 1.4);
  if (b > 255) then b := 255;

  Result.rgbRed   := r;
  Result.rgbGreen := g;
  Result.rgbBlue  := b;
end;

function ResampleBitmap(Bitmap: TBitmap; NewWidth, NewHeight: Integer): Boolean;
var
  Temp: TBitmap;
  Line: PLine;
  x, y: Integer;
  Blockheight, Blockwidth: Cardinal;
  BlockPosX, BlockPosY: Single;
  BlockDiffX, BlockDiffY: Single;
  XPos, YPos: Single;
  DiffX, Diffy: Single;
begin
  Result := True;

  //Arbeitsbitmap erzeugen
  Temp := TBitmap.Create;

  //Alles muß 32 Bit sein
  Bitmap.PixelFormat := pf32Bit;
  Temp.PixelFormat   := pf32Bit;

  //Neue Höhe unseres Bitmap
  Temp.Height := NewHeight;
  Temp.Width  := NewWidth;

  //Altes Bild in Blöcke zerlegen, deren jeweiliger Mittelwert die Farbe
  //eines neuen Pixels bildet
  //Blockschrittweite pro neues Pixel
  BlockDiffY := (Bitmap.Height / NewHeight);
  BlockDiffX := (Bitmap.Width / NewWidth);
  //Größe eines Blockes
  BlockHeight := Trunc(BlockDiffY);
  BlockWidth  := Trunc(BlockDiffY);


  //Schrittweite der Pixel im neuen Bild
  DiffX := 1;
  DiffY := 1;

  //Alle initialisieren
  BlockPosY := 0;
  YPos      := 0;
  //Jede Spalte
  for y := 0 to NewHeight - 1 do
  begin
    BlockPosX := 0;
    XPos      := 0;
    //Jede Zeile
    Line := Temp.ScanLine[Trunc(YPos)];
    for x := 0 to NewWidth - 1 do
    begin
      //Aus einem angegebenen Block des alten Bitmaps den Mittelwert der
      //Farbe bestimmen
      Line[Trunc(XPos)] := ResampleSubBitmap(Bitmap,
        Round(BlockPosX), Round(BlockPosY), Blockwidth, BlockHeight);

      //Einen Block/Pixel weiter
      BlockPosX := BlockPosX + BlockDiffX;
      XPos      := XPos + DiffX;
    end;
    //Einen Block/Pixel weiter
    BlockPosY := BlockPosY + BlockDiffY;
    YPos      := YPos + DiffY;
  end;
  //Alte Bitmap mit der neuen überschreiben
  Bitmap.Assign(Temp);

  //Hilfsbitmap freigeben
  Temp.Free;
end;


// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
  ResampleBitmap(Image1.Picture.Bitmap, 30, 30);
end;