// Querverweis: ein Bitmap mit einem Raster überblenden
// oder auch:   Zeitungs-Raster nachempfinden

// Was mit "eingefärbten Raster-Bitmaps" gemeint ist, sieht man am besten
// an den Abbildungen.

// Die Funktion "
Rastern" erwartet vier Parameter:
// 1.
Farbe: TColor
//    Hiermit wird die Art der Einfärbung festgelegt. Das Programm nutzt
//    dabei die Differenz zwischen dem Rot-, Grün- und Blau-Anteil dieser
//    Farbe. Angaben wie
clBlack, clGray oder clWhite erzielen keinerlei
//    Unterschiede, da hier alle drei Farbanteile gleich sind. Das Rasterbild
//    würde deshalb jeweils grau dargestellt werden.
// 2.
Gerastert: Boolean
//    Legt fest, ob das Bild überhaupt geraster wird, oder nur eingefärbt.
// 3.
Vergroessern: Boolean
//    Damit keine unterschiedlich breiten Raster entstehen, wird das Bild
//   
(falls nötig) in Breite und Höhe angepasst. Mit diesem Parameter wird
//    nun festgelegt, ob das Original-BildBild um 1 bis 2 Pixel vergrößert
//    oder verkleinert wird.
// 4.
Einfaerben: Single
//    Dieser Parameter kann im Bereich von 1 bis 5 liegen und legt fest,
//    wie intensiv die Farbe genutzt wird. Werte zwischen 3 und 3.5
//    dürften die Besten Ergebnisse bringen.


// Wenn Sie den Code mit dem von Bitmaps animieren kombinieren, können Sie
// auch bewegte Raster-Bilder erzeugen:


(Falls Sie hier keine Bewegung sehen, müssen Sie die Seite aktualisieren)
 

// P.S.
// Die Assembler-Routinen sollten eigentlich einen Geschwindigkeitsvorteil
// bringen. Auf meinem Computer haben Messungen ergeben, dass dieser pro
// Bild etwa nur eine halbe Millisekunde beträgt. Ich habe die Routinen
// trotzdem drin gelassen.

// Getestet mit D4 unter WinME

var 
  Original, Raster: TBitmap; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Original := TBitmap.create; 
  Raster := TBitmap.create; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  Raster.free; 
  Original.free; 
end; 
 
function Rastern(farbe: TColor; gerastert, vergroessern: boolean; 
  einfaerbung: single): boolean; 
var 
  p1, p2: PBytearray; 
  x, y, gr, br, r, g, b, d, r2, g2, b2: integer; 
  function a3(p: pointer): integer; stdcall; 
  asm 
    xor ecx,ecx 
    mov edx,p 
    mov cl,[edx] 
    mov eax,ecx 
    inc edx 
    mov cl,[edx] 
    add eax,ecx 
    inc edx 
    mov cl,[edx] 
    add eax,ecx 
    mov @result,eax 
  end; 
  function g255(i: integer): byte; stdcall; 
  asm 
    mov eax,i 
    cmp eax,$FF 
    jle @fertig 
    mov eax,$FF 
   @fertig: 
    mov @result,al 
  end; 
  procedure k0(i, j, k: pointer); stdcall; 
  asm 
    mov edx,i 
    mov ecx,[edx] 
    cmp ecx,0 
    jge @hinter_i 
    xor eax,eax 
    mov [edx],eax 
    mov edx,j 
    mov eax,[edx] 
    sub eax,ecx 
    mov [edx],eax 
    mov edx,k 
    mov eax,[edx] 
    sub eax,ecx 
    mov [edx],eax 
   @hinter_i: 
    mov edx,j 
    mov ecx,[edx] 
    cmp ecx,0 
    jge @hinter_j 
    xor eax,eax 
    mov [edx],eax 
    mov edx,i 
    mov eax,[edx] 
    sub eax,ecx 
    mov [edx],eax 
    mov edx,k 
    mov eax,[edx] 
    sub eax,ecx 
    mov [edx],eax 
   @hinter_j: 
    mov edx,k 
    mov ecx,[edx] 
    cmp ecx,0 
    jge @hinter_k 
    xor eax,eax 
    mov [edx],eax 
    mov edx,i 
    mov eax,[edx] 
    sub eax,ecx 
    mov [edx],eax 
    mov edx,j 
    mov eax,[edx] 
    sub eax,ecx 
    mov [edx],eax 
   @hinter_k: 
  end; 
  procedure anpassen; 
  begin 
    Raster.width := Original.width; 
    Raster.height := Original.height; 
  end; 
  procedure addieren; 
  begin 
    b2 := d + b; 
    g2 := d + g; 
    r2 := d + r; 
    k0(@b2, @g2, @r2); 
    p2[x] := g255(b2); 
    p2[x + 1] := g255(g2); 
    p2[x + 2] := g255(r2); 
  end; 
begin 
  result := false; 
  if (Original.width < 5) or 
    (Original.height < 5) then exit; 
  try 
    Original.pixelformat := pf24bit; 
    Raster.pixelformat := pf24bit; 
    if einfaerbung < 1 then einfaerbung := 1 else 
      if einfaerbung > 5 then einfaerbung := 5; 
    einfaerbung := abs(einfaerbung - 6); 
    einfaerbung := einfaerbung * einfaerbung / 6 + 1; 
    farbe := colortorgb(farbe); 
    r := getrvalue(farbe); 
    g := getgvalue(farbe); 
    b := getbvalue(farbe); 
    d := (r + g + b) div 3; 
    r := round((r - d) / einfaerbung); 
    g := round((g - d) / einfaerbung); 
    b := round((b - d) / einfaerbung); 
    gr := ord(vergroessern) * 2 - 1; 
    anpassen; 
    Raster.canvas.draw(0, 0, Original); 
    while frac((Original.width - 2) / 3) <> 0 do 
      Original.width := Original.width + gr; 
    while frac((Original.height - 2) / 3) <> 0 do 
      Original.height := Original.height + gr; 
    Original.canvas.stretchdraw(rect 
      (0, 0, Original.width, Original.height), Raster); 
    anpassen; 
    br := Original.width * 3; 
    for y := 0 to Original.height - 1 do begin 
      p1 := Original.ScanLine[y]; 
      p2 := Raster.ScanLine[y]; 
      x := 0; 
      while x < br do begin 
        if gerastert and ((x mod 9 = 6) 
          or (y mod 3 = 2)) 
          then zeromemory(@p2[x], 3) 
        else begin 
          d := a3(@p1[x]) div 3; 
          addieren; 
        end; 
        inc(x, 3); 
      end; 
    end; 
  except exit end; 
  result := true; 
end; 
 
// Beispielaufruf (siehe obige Abbildung) 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Original.loadfromfile('d:\bilder\frau8.bmp'); 
  rastern(clyellow, true, true, 3.5); 
  canvas.draw(5, 5, Original); 
  canvas.draw(Raster.width + 10, 5, Raster); 
  rastern(clmaroon, true, true, 4); 
  canvas.draw(Raster.width * 2 + 15, 5, Raster); 
  rastern(clblue, true, true, 2.5); 
  canvas.draw(Raster.width * 3 + 20, 5, Raster); 
 { 
  // eine Reihe ohne Raster (nur eingefärbt) erzeugen: 
  rastern(clyellow, false, true, 3.5); 
  canvas.draw(Raster.width + 10, Raster.height + 10, Raster); 
  rastern(clmaroon, false, true, 4); 
  canvas.draw(Raster.width * 2 + 15, Raster.height + 10, Raster); 
  rastern(clblue, false, true, 2.5); 
  canvas.draw(Raster.width * 3 + 20, Raster.height + 10, Raster); 
 } 
end;



Zugriffe seit 6.9.2001 auf Delphi-Ecke