DBR Delphi-Ecke

// Eine Bitmap wird in Mosaiksteine zerlegt.

// Getestet mit D4 unter XP


Original	Variante 1 Faktor 4


Variante 2 Mosaiksteingröße 4 ohne Schattierung (waagerecht 0 senkrecht 0)	Variante 2 Mosaiksteingröße 4 mit Schattierung (waagerecht -45 senkrecht +45)

// Variante 1: Einfacher Code

function mosaik(source, dest: TBitmap; faktor: byte): boolean; 
var hlp: TBitmap; 
begin 
  result := false; 
  if (faktor < 3) or (faktor > source.width div 2) 
    or (faktor > source.height div 2) then exit; 
  hlp := TBitmap.create; 
  hlp.width := source.width div faktor; 
  hlp.height := source.height div faktor; 
  hlp.canvas.stretchdraw(rect(0, 0, hlp.width, hlp.height), source); 
  dest.width := source.width; 
  dest.height := source.height; 
  dest.canvas.stretchdraw(rect(0, 0, dest.width, dest.height), hlp); 
  hlp.free; 
  result := true; 
end; 
 
 
// Beispielaufruf 
procedure TForm1.Button1Click(Sender: TObject); 
var bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  if not 
    mosaik(Image1.picture.bitmap, bm, 4) 
    then showmessage('Fehler') else 
    canvas.draw(Image1.left, Image1.top, bm); 
  bm.free; 
end;

// -------------------------------------------------------------------

// Variante 2:

// Das Bild wird bei Bedarf in der Größe so angepasst, dass alle Mosaiksteine
// in voller Größe dargestellt werden können. Mit den Variablen "waagerecht"
// und "senkrecht" kann eine waagerecht und/oder senkrecht verlaufende
// Aufhellung bzw. Abdunkelung der einzelnen Mosaiksteine erreicht werden,
// was das Mosaik plastischer erscheinen läßt.

procedure mosaik(src: TGraphic; dest: TBitmap; 
  steingrsse: byte; waagerecht, senkrecht: integer; anpassen: boolean); 
var x, y, s3, b3: integer; 
  ww, ws: single; 
  function addieren(b: byte; i, j: integer): byte; 
  var h: integer; 
  begin 
    h := trunc(b + i * ww + j * ws); 
    if h < 0 then result := 0 else 
      if h > 255 then result := 255 
      else result := h; 
  end; 
  procedure makesteingrsse(i, j: integer); 
  var w, h, k: integer; 
    p: pbytearray; 
    r, g, b: byte; 
  begin 
    r := 127; 
    g := r; 
    b := r; 
    for h := 0 to steingrsse - 1 do 
      if j + h < dest.height then begin 
        w := 0; 
        p := dest.scanline[j + h]; 
        while w < s3 do begin 
          k := i + w; 
          if k >= b3 then break; 
          b := (p[k] + b) div 2; 
          g := (p[k + 1] + g) div 2; 
          r := (p[k + 2] + r) div 2; 
          inc(w, 3); 
        end; 
      end; 
    for h := 0 to steingrsse - 1 do 
      if j + h < dest.height then begin 
        w := 0; 
        p := dest.scanline[j + h]; 
        while w < s3 do begin 
          k := i + w; 
          if k >= b3 then break; 
          p[k] := addieren(b, w, h); 
          p[k + 1] := addieren(g, w, h); 
          p[k + 2] := addieren(r, w, h); 
          inc(w, 3); 
        end; 
      end; 
  end; 
begin 
  dest.pixelformat := pf24bit; 
  if anpassen then begin 
    dest.width := ((src.width + steingrsse) div steingrsse) * steingrsse; 
    dest.height := ((src.height + steingrsse) div steingrsse) * steingrsse; 
  end else begin 
    dest.width := src.width; 
    dest.height := src.height; 
  end; 
  dest.canvas.stretchdraw(dest.canvas.cliprect, src); 
  s3 := steingrsse * 3; 
  b3 := dest.width * 3; 
  if waagerecht = 0 then ww := 0 else 
    ww := ((waagerecht * 0.67) / (steingrsse * 3)); 
  if senkrecht = 0 then ws := 0 else 
    ws := (senkrecht / (steingrsse * 3)); 
  for y := 0 to dest.height div steingrsse do 
    for x := 0 to b3 div steingrsse do 
      makesteingrsse(x * s3, y * steingrsse); 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button2Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  mosaik(Image1.picture.graphic, bm, 4, -45, 45, true); 
  canvas.draw(Image1.left + Image1.width, Image1.top, bm); 
  bm.free; 
end;