whats new ¦  programming tips ¦  indy articles ¦  intraweb articles ¦  informations ¦  links ¦  interviews
 misc ¦  tutorials ¦  Add&Win Game

Tips (1548)

Database (90)
Files (137)
Forms (107)
Graphic (116)
IDE (21)
Indy (5)
Internet / LAN (131)
IntraWeb (0)
Math (76)
Misc (127)
Multimedia (45)
Objects/
ActiveX (51)

OpenTools API (3)
Printing (35)
Strings (83)
System (268)
VCL (243)

Top15

Tips sort by
component


Search Tip

Add new Tip

Add&Win Game

Advertising

17 Visitors Online


 
...resample a Bitmap?
Autor: Sven Lorenz
Homepage: http://www.Sven-of-Nine.de
[ Print tip ]  

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;


 

Rate this tip:

poor
very good


Copyright © by SwissDelphiCenter.ch
All trademarks are the sole property of their respective owners