// Querverweis: ein Bitmap mit einem Raster überblenden
// oder auch:   eingefärbte Raster-Bitmaps erstellen

// Lange Zeit (heute wohl auch noch) wurden Zeitungsbilder je nach
// Helligkeitswert mit unterschiedlich großen Punkten bzw. mit geringerer
// oder höherer Punktanzahl pro gleicher Fläche dargestellt.
// Das kann man beispielsweise auch zur dekorativen Gestaltung einer
// Web-Seiten einsetzen. Das Ganze könnte dann so aussehen:

// Getestet mit D4 unter WinME


// Variante 1.1: Unterschiedliche Punktgröße (kleine Punkte)

Original Raster 
var 
  bm: array[0..3] of TBitmap; 
  Untergrund: TColor = $EFE0E0; 
  Punkte: TColor = $400000; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to 3 do begin 
    bm[x] := TBitmap.create; 
    bm[x].width := 3; 
    bm[x].height := 3; 
    if x > 1 then 
      bm[x].canvas.brush.color := Punkte else 
      bm[x].canvas.brush.color := Untergrund; 
    bm[x].canvas.fillrect(bm[x].canvas.cliprect); 
  end; 
  bm[1].canvas.pixels[1, 1] := Punkte; 
  bm[2].canvas.pixels[0, 0] := Untergrund; 
  bm[2].canvas.pixels[2, 0] := Untergrund; 
  bm[2].canvas.pixels[0, 2] := Untergrund; 
  bm[2].canvas.pixels[2, 2] := Untergrund; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var 
  x: integer; 
begin 
  for x := 0 to 3 do 
    bm[x].free; 
end; 
 
procedure raster3(bmp: TBitmap); 
var 
  x, y, z, b3, w: integer; 
  p1, p2, p3: PBytearray; 
begin 
  bmp.pixelformat := pf24bit; 
  b3 := bmp.width * 3; 
  y := 0; 
  while y < bmp.height do begin 
    p1 := bmp.scanline[y]; 
    p2 := bmp.scanline[y + 1]; 
    p3 := bmp.scanline[y + 2]; 
    x := 0; 
    while x < b3 do begin 
      w := 0; 
      for z := 0 to 2 do begin 
        w := w + p1[x + z]; 
        w := w + p2[x + z]; 
        w := w + p3[x + z]; 
      end; 
      case w of 
        0..800: bmp.canvas.draw(x div 3, y, bm[3]); 
        801..1350: bmp.canvas.draw(x div 3, y, bm[2]); 
        1351..2150: bmp.canvas.draw(x div 3, y, bm[1]); 
      else bmp.canvas.draw(x div 3, y, bm[0]); 
      end; 
      inc(x, 9); 
    end; 
    inc(y, 3); 
  end; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  bmp: TBitmap; 
begin 
  bmp := TBitmap.create; 
  bmp.width := (Image1.Picture.bitmap.width div 3) * 3; 
  bmp.height := (Image1.Picture.bitmap.height div 3) * 3; 
  bmp.canvas.stretchdraw(bmp.canvas.cliprect, Image1.picture.graphic); 
  raster3(bmp); 
  Image1.picture.bitmap.assign(bmp); 
  bmp.free; 
end;

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

// Variante 1.2: Unterschiedliche Punktgröße (große Punkte)

Original Variante 1.2a (2 Farben) Variante 1.2b (3 Farben) 
// Variante 1.2a: Zwei Farben

var 
  schablone: array[0..5] of TBitmap; 
  papierR, papierG, papierB, stiftR, stiftG, stiftB: byte; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var x: integer; 
begin 
  for x := 0 to 5 do begin 
    schablone[x] := TBitmap.create; 
    with schablone[x] do begin 
      width := 5; 
      height := 5; 
      pixelformat := pf24bit; 
      with canvas do begin 
        if x > 3 then 
          brush.color := clwhite else 
          brush.color := clblack; 
        fillrect(cliprect); 
        brush.style := bsclear; 
      end; 
    end; 
  end; 
  with schablone[1] do 
    with canvas do begin 
      pixels[0, 0] := clwhite; 
      pixels[0, height - 1] := clwhite; 
      pixels[width - 1, 0] := clwhite; 
      pixels[width - 1, height - 1] := clwhite; 
    end; 
  with schablone[2] do 
    with canvas do begin 
      pixels[0, 0] := clwhite; 
      pixels[1, 0] := clwhite; 
      pixels[0, 1] := clwhite; 
      pixels[width - 1, 0] := clwhite; 
      pixels[width - 2, 0] := clwhite; 
      pixels[width - 1, 1] := clwhite; 
      pixels[0, height - 1] := clwhite; 
      pixels[1, height - 1] := clwhite; 
      pixels[0, height - 2] := clwhite; 
      pixels[width - 1, height - 1] := clwhite; 
      pixels[width - 1, height - 2] := clwhite; 
      pixels[width - 2, height - 1] := clwhite; 
    end; 
  with schablone[3] do 
    with canvas do begin 
      pen.color := clwhite; 
      rectangle(0, 0, width, height); 
      pixels[1, 1] := clwhite; 
      pixels[1, height - 1 - 1] := clwhite; 
      pixels[width - 1 - 1, 1] := clwhite; 
      pixels[width - 1 - 1, height - 1 - 1] := clwhite; 
    end; 
  schablone[4].canvas.pixels[2, 2] := clblack; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var x: integer; 
begin 
  for x := 0 to 5 do schablone[x].free; 
end; 
 
procedure farben(f: TColor; var r, g, b: byte); 
begin 
  f := colortorgb(f); 
  r := getrvalue(f); 
  g := getgvalue(f); 
  b := getbvalue(f); 
end; 
 
procedure einsetzen(bild: TBitmap; i, w, s: integer); 
var 
  x, y: integer; 
  ps: PBytearray; 
  p: pbytearray; 
begin 
  for y := 0 to 4 do begin 
    x := 0; 
    p := bild.scanline[s + y]; 
    ps := schablone[i].scanline[y]; 
    while x < 15 do begin 
      if ps[x] = 0 then p[w + x] := stiftB 
      else p[w + x] := papierB; 
      if ps[x + 1] = 0 then p[w + 1 + x] := stiftG 
      else p[w + 1 + x] := papierG; 
      if ps[x + 2] = 0 then p[w + 2 + x] := stiftR 
      else p[w + 2 + x] := papierR; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
function rasterbild(bild: TBitmap; fStift, fPapier: TColor): boolean; 
var 
  x, y, z, w, b, s: integer; 
  h: TBitmap; 
  p: pbytearray; 
begin 
  result := false; 
  if (bild.width <= 5) or (bild.height <= 5) 
    or (fStift = fPapier) 
    then exit; 
  farben(fStift, stiftR, stiftG, stiftB); 
  farben(fpapier, papierR, papierG, papierB); 
  try 
    bild.pixelformat := pf24bit; 
    h := TBitmap.create; 
    h.assign(bild); 
    b := 5 - bild.width mod 5; 
    dec(b, ord(b = 5) * 5); 
    bild.width := bild.width + b; 
    b := 5 - bild.height mod 5; 
    dec(b, ord(b = 5) * 5); 
    bild.height := bild.height + b; 
    bild.canvas.stretchdraw(rect(0, 0, bild.width, bild.height), h); 
    h.free; 
    b := bild.width * 3; 
    x := 0; 
    while x < b do begin 
      y := 0; 
      while y < bild.height do begin 
        s := 0; 
        for z := 0 to 4 do begin 
          p := bild.scanline[y + z]; 
          for w := 0 to 14 do s := s + p[x + w]; 
        end; 
        case s of 
          0..3000: einsetzen(bild, 0, x, y); 
          3001..7500: einsetzen(bild, 1, x, y); 
          7501..12000: einsetzen(bild, 2, x, y); 
          12001..16500: einsetzen(bild, 3, x, y); 
          16501..18375: einsetzen(bild, 4, x, y); 
        else einsetzen(bild, 5, x, y); 
        end; 
        inc(y, 5); 
      end; 
      inc(x, 15); 
    end; 
  except 
    exit; 
  end; 
  result := true; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button9Click(Sender: TObject); 
var bmp: TBitmap; 
begin 
  bmp := TBitmap.create; 
  bmp.loadfromfile('c:\merkel.bmp'); 
  canvas.Draw(0, 5, bmp); 
  if not rasterbild(bmp, clblack, $EED0D0) 
    then showmessage('FEHLER') else 
    canvas.Draw(200, 5, bmp); 
  bmp.free; 
end;

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

// Variante 1.2b: Drei Farben

var
  schablone: array[0..5] of TBitmap;
  papierR, papierG, papierB, stiftR, stiftG, stiftB,
    stiftR2, stiftG2, stiftB2: byte;
 
procedure TForm1.FormCreate(Sender: TObject);
var x: integer;
begin
  for x := 0 to 5 do begin
    schablone[x] := TBitmap.create;
    with schablone[x] do begin
      width := 5;
      height := 5;
      pixelformat := pf24bit;
      with canvas do begin
        if x > 3 then
          brush.color := clwhite else
          brush.color := clblack;
        fillrect(cliprect);
        brush.style := bsclear;
      end;
    end;
  end;
  with schablone[1] do
    with canvas do begin
      pixels[0, 0] := clwhite;
      pixels[0, height - 1] := clwhite;
      pixels[width - 1, 0] := clwhite;
      pixels[width - 1, height - 1] := clwhite;
    end;
  with schablone[2] do
    with canvas do begin
      pixels[0, 0] := clwhite;
      pixels[1, 0] := clwhite;
      pixels[0, 1] := clwhite;
      pixels[width - 1, 0] := clwhite;
      pixels[width - 2, 0] := clwhite;
      pixels[width - 1, 1] := clwhite;
      pixels[0, height - 1] := clwhite;
      pixels[1, height - 1] := clwhite;
      pixels[0, height - 2] := clwhite;
      pixels[width - 1, height - 1] := clwhite;
      pixels[width - 1, height - 2] := clwhite;
      pixels[width - 2, height - 1] := clwhite;
    end;
  with schablone[3] do
    with canvas do begin
      pen.color := clwhite;
      rectangle(0, 0, width, height);
      pixels[1, 1] := clwhite;
      pixels[1, height - 1 - 1] := clwhite;
      pixels[width - 1 - 1, 1] := clwhite;
      pixels[width - 1 - 1, height - 1 - 1] := clwhite;
    end;
  schablone[4].canvas.pixels[2, 2] := clblack;
end;
 
procedure TForm1.FormDestroy(Sender: TObject);
var x: integer;
begin
  for x := 0 to 5 do schablone[x].free;
end;
 
procedure farben(f: TColor; var r, g, b: byte);
begin
  f := colortorgb(f);
  r := getrvalue(f);
  g := getgvalue(f);
  b := getbvalue(f);
end;
 
procedure einsetzen(bild: TBitmap; i, w, s: integer; sr, sg, sb: byte);
var
  x, y: integer;
  ps: PBytearray;
  p: pbytearray;
begin
  for y := 0 to 4 do begin
    x := 0;
    p := bild.scanline[s + y];
    ps := schablone[i].scanline[y];
    while x < 15 do begin
      if ps[x] = 0 then p[w + x] := sb
      else p[w + x] := papierB;
      if ps[x + 1] = 0 then p[w + 1 + x] := sg
      else p[w + 1 + x] := papierG;
      if ps[x + 2] = 0 then p[w + 2 + x] := sr
      else p[w + 2 + x] := papierR;
      inc(x, 3);
    end;
  end;
end;
 
function rasterbild(bild: TBitmap; fStift, fPapier, fStift2: TColor): boolean;
var
  x, y, z, w, b, s: integer;
  h: TBitmap;
  p: pbytearray;
begin
  result := false;
  if (bild.width <= 5) or (bild.height <= 5)
    or (fStift = fPapier) or (fStift2 = fPapier) or (fStift = fStift2)
    then exit;
  farben(fStift, stiftR, stiftG, stiftB);
  farben(fStift2, stiftR2, stiftG2, stiftB2);
  farben(fpapier, papierR, papierG, papierB);
  try
    bild.pixelformat := pf24bit;
    h := TBitmap.create;
    h.assign(bild);
    b := 5 - bild.width mod 5;
    dec(b, ord(b = 5) * 5);
    bild.width := bild.width + b;
    b := 5 - bild.height mod 5;
    dec(b, ord(b = 5) * 5);
    bild.height := bild.height + b;
    bild.canvas.stretchdraw(rect(0, 0, bild.width, bild.height), h);
    h.free;
    b := bild.width * 3;
    x := 0;
    while x < b do begin
      y := 0;
      while y < bild.height do begin
        s := 0;
        for z := 0 to 4 do begin
          p := bild.scanline[y + z];
          for w := 0 to 14 do s := s + p[x + w];
        end;
        case s of
          0..1750: einsetzen(bild, 0, x, y, stiftR, stiftG, stiftB);
          1751..3500: einsetzen(bild, 1, x, y, stiftR, stiftG, stiftB);
          3501..5260: einsetzen(bild, 2, x, y, stiftR, stiftG, stiftB);
          5261..7000: einsetzen(bild, 3, x, y, stiftR, stiftG, stiftB);
          7001..9000: einsetzen(bild, 4, x, y, stiftR, stiftG, stiftB);
          9001..10850: einsetzen(bild, 5, x, y, stiftR, stiftG, stiftB);
          10851..12500: einsetzen(bild, 4, x, y, stiftR2, stiftG2, stiftB2);
          12501..14200: einsetzen(bild, 3, x, y, stiftR2, stiftG2, stiftB2);
          14201..15900: einsetzen(bild, 2, x, y, stiftR2, stiftG2, stiftB2);
          15901..17800: einsetzen(bild, 1, x, y, stiftR2, stiftG2, stiftB2);
        else einsetzen(bild, 0, x, y, stiftR2, stiftG2, stiftB2);
        end;
        inc(y, 5);
      end;
      inc(x, 15);
    end;
  except
    exit;
  end;
  result := true;
end;
 
 
// Beispielaufruf

procedure TForm1.Button1Click(Sender: TObject);
var bmp: TBitmap;
begin
  bmp := TBitmap.create;
  bmp.loadfromfile('c:\merkel.bmp');
  canvas.Draw(10, 5, bmp);
  if not rasterbild(bmp, $503030, $AA9090, $FFEFEF)
    then showmessage('FEHLER') else
    canvas.Draw(200, 5, bmp);
  bmp.free;
end;


 

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

// Variante 2: Unterschiedliche Punktanzahl
 

type 
  b3 = array[0..3] of byte; 
 
var 
  bild: TBitmap; 
  schablone: array[0..6] of TBitmap; 
  farbe: array[0..1] of TColor; 
  anteil: array[0..1] of b3; 
 
procedure vorbereitung; 
var i: integer; 
begin 
  for i := 0 to 1 do begin 
    farbe[i] := ColorToRGB(farbe[i]); 
    anteil[i][0] := GetBValue(farbe[i]); 
    anteil[i][1] := GetGValue(farbe[i]); 
    anteil[i][2] := GetRValue(farbe[i]); 
  end; 
end; 
 
procedure schablonen; 
var x, y, i: integer; 
begin 
  for i := 1 to 5 do begin 
    with schablone[i].canvas do begin 
      case i of 
        1: pixels[2, 2] := 0; 
        2: begin 
            pixels[2, 1] := 0; 
            pixels[0, 2] := 0; 
          end; 
        3: begin 
            pixels[0, 0] := 0; 
            pixels[0, 2] := 0; 
            pixels[2, 1] := 0; 
            pixels[2, 3] := 0; 
          end; 
        4: begin 
            for x := 0 to 3 do 
              for y := 0 to 3 do begin 
                if odd(x) = odd(y) then 
                  pixels[x, y] := 0; 
              end; 
          end; 
        5: begin 
            pixels[2, 0] := $FFFFFF; 
            pixels[0, 1] := $FFFFFF; 
            pixels[2, 2] := $FFFFFF; 
            pixels[0, 3] := $FFFFFF; 
          end; 
      end; 
    end; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
var x: integer; 
begin 
  bild := TBitmap.create; 
  for x := 0 to 6 do begin 
    schablone[x] := TBitmap.create; 
    with schablone[x] do begin 
      width := 4; 
      height := 4; 
      pixelformat := pf24bit; 
      with canvas do begin 
        brush.color := ord(x < 5) * $FFFFFF; 
        fillrect(cliprect); 
      end; 
    end; 
  end; 
  schablonen; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var x: integer; 
begin 
  for x := 0 to 6 do schablone[x].free; 
  bild.free; 
end; 
 
procedure einsetzen(bm: TBitmap; i, w, s: integer); 
var 
  x, y: integer; 
  ps: PBytearray; 
  p: pbytearray; 
begin 
  for y := 0 to 3 do begin 
    x := 0; 
    p := bm.scanline[s + y]; 
    ps := schablone[i].scanline[y]; 
    while x < 12 do begin 
      if ps[x] = 0 then p[w + x] := anteil[0][0] 
      else p[w + x] := anteil[1][0]; 
      if ps[x + 1] = 0 then p[w + 1 + x] := anteil[0][1] 
      else p[w + 1 + x] := anteil[1][1]; 
      if ps[x + 2] = 0 then p[w + 2 + x] := anteil[0][2] 
      else p[w + 2 + x] := anteil[1][2]; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
function rasterbild(bm: TBitmap): boolean; 
var 
  x, y, z, w, b, s: integer; 
  h: TBitmap; 
  p: pbytearray; 
begin 
  result := false; 
  if (bm.width < 4) or (bm.height < 4) 
    or (farbe[0] = farbe[1]) 
    then exit; 
  bm.pixelformat := pf24bit; 
  try 
    h := TBitmap.create; 
    h.assign(bm); 
    b := 4 - bm.width mod 4; 
    dec(b, ord(b = 4) * 4); 
    bm.width := bm.width + b; 
    b := 4 - bm.height mod 4; 
    dec(b, ord(b = 4) * 4); 
    bm.height := bm.height + b; 
    bm.canvas.stretchdraw(rect(0, 0, bm.width, bm.height), h); 
    h.free; 
    b := bm.width * 3; 
    x := 0; 
    while x < b do begin 
      y := 0; 
      while y < bm.height do begin 
        s := 0; 
        for z := 0 to 3 do begin 
          p := bm.scanline[y + z]; 
          for w := 0 to 11 do s := s + p[x + w]; 
        end; 
        case s of 
          0..1300: einsetzen(bm, 0, x, y); 
          1301..2500: einsetzen(bm, 1, x, y); 
          2501..4700: einsetzen(bm, 2, x, y); 
          4701..6000: einsetzen(bm, 3, x, y); 
          6001..7700: einsetzen(bm, 4, x, y); 
          7701..10000: einsetzen(bm, 5, x, y); 
        else einsetzen(bm, 6, x, y); 
        end; 
        inc(y, 4); 
      end; 
      inc(x, 12); 
    end; 
  except 
    exit; 
  end; 
  result := true; 
end; 
 
procedure TForm1.Button9Click(Sender: TObject); 
begin 
  farbe[0] := $EED0D0; // Hintergrund; 
  farbe[1] := $100000; // Punkte 
  vorbereitung; 
  bild.loadfromfile('c:\merkel.bmp'); 
  canvas.draw(10, 25, bild); 
  rasterbild(bild); 
  canvas.draw(20 + bild.width, 25, bild); 
end;
Zugriffe seit 6.9.2001 auf Delphi-Ecke