Mega Code Archive
Resample a Bitmap
<![CDATA[
Title: resample a Bitmap?
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;
]]>