DBR Delphi-Ecke

// Mit dem folgenden Code kann man aus einem Bitmap eine Prägung (ein Relief)
// ohne Farbschlieren berechnen lassen. Es werden die Übergänge von hellen zu
// dunklen Flächen als Kanten genutzt. Die Variable "Farbe" legt dabei nur die
// farbliche Grundstimmung des Reliefs fest. Die Variable "Stufe" ist in
// gewissen Grenzen für die Stärke des Reliefs zuständig. Für kontrastreiche
// Bilder sollte ihr Wert unter "64" liegen, bei sehr flauen Bildern über "191".
// Die Variable "Negativ" bestimmt wie die Hell-Dunkel-Übergänge dargestellt
// werden, das Relief erscheint entweder erhaben oder versunken. Die Variable
// "Solarisation" bestimmt gleichzeitig die Helligkeit und das Verhältnis von
// Licht und Schatten zueinander. Standardmäßig sollte diese Variable immer den
// Wert "215" haben. Bei "Muster" kann man ein Bild angeben, das
// als eine Art Wasserzeichen unter das Relief gelegt wird.

// Getestet mit D4 unter WinXP

procedure Relief(Bitmap, Muster: TBitmap; Farbe: TColor; 
  Stufe, Solarisation: Byte; Negativ: Boolean); 
var 
  x, y, b3, schwelle: Integer; 
  p1, p2, p3: PByteArray; 
  a, r, g, b, h: Byte; 
  bm, bmm: TBitmap; 
  m: boolean; 
  function grenze(b: byte): byte; 
  begin 
    if b > schwelle then result := 255 else 
      if b < solarisation then result := 0 
      else result := b; 
  end; 
  function rechne(bb: byte): integer; 
  begin 
    if bb > 120 then Result := bb + stufe else Result := bb - stufe; 
    if Result < 0 then Result := 0 else if Result > 255 then Result := 255; 
  end; 
begin 
  farbe := colortorgb(farbe); 
  r := getrvalue(farbe); 
  g := getgvalue(farbe); 
  b := getbvalue(farbe); 
  m := muster <> nil; 
  a := 2 + stufe div 191 - ord(stufe < 64); 
  stufe := stufe shr 1; 
  solarisation := 255 - solarisation; 
  schwelle := solarisation * 6 + 30; 
  bm := TBitmap.create; 
  bm.pixelformat := pf24bit; 
  bmm := TBitmap.create; 
  bmm.pixelformat := pf24bit; 
  bitmap.pixelformat := pf24bit; 
  bm.width := bitmap.width + 2; 
  bm.height := bitmap.height + a; 
  bmm.width := bm.width; 
  bmm.height := bm.height; 
  bm.canvas.draw(0, 0, bitmap); 
  if m then 
    bmm.canvas.stretchdraw(rect(0, 0, bmm.width, bmm.height), muster); 
  bm.canvas.copyrect(rect(0, bitmap.height, bitmap.width, bm.height), 
    bitmap.canvas, rect(0, bitmap.height - a, bitmap.width, bitmap.height)); 
  bm.canvas.copyrect(rect(bitmap.width, 0, bm.width, bitmap.height), 
    bitmap.canvas, rect(bitmap.width - 2, 0, bitmap.width, bitmap.height)); 
  b3 := bm.width * 3 - 1; 
  for y := 0 to bitmap.height - 1 do 
  begin 
    p1 := bm.ScanLine[y]; 
    p2 := bm.ScanLine[y + a]; 
    p3 := bmm.scanline[y]; 
    x := 0; 
    while x < b3 do 
    begin 
      h := (rechne(p1[x]) + (rechne(p2[x]) xor $FF) + 
        rechne(p1[x + 1]) + (rechne(p2[x + 4]) xor $FF) + 
        rechne(p1[x + 2]) + (rechne(p2[x + 8]) xor $FF)) div 6; 
      if negativ then h := 255 - h; 
      p1[x] := grenze((h + b) shr 1); 
      p1[x + 1] := grenze((h + g) shr 1); 
      p1[x + 2] := grenze((h + r) shr 1); 
      if m then begin 
        p1[x] := (p1[x] shl 1 + p3[x]) div 3; 
        p1[x + 1] := (p1[x + 1] shl 1 + p3[x + 1]) div 3; 
        p1[x + 2] := (p1[x + 2] shl 1 + p3[x + 2]) div 3; 
      end; 
      inc(x, 3); 
    end; 
  end; 
  bitmap.canvas.draw(0, 0, bm); 
  bm.free; 
  bmm.free; 
end;

//--------------------- Beispielaufrufe ------------------------

procedure TForm1.Button5Click(Sender: TObject); 
var 
  b: TBitmap; 
begin 
  b := TBitmap.create; 
  b.loadfromfile('d:\bilder\frau.bmp'); 
  canvas.draw(10, 10, b); 
  Relief(b, nil, clgray, 80, 215, false); 
  canvas.draw(b.width + 20, 10, b); 
  b.free; 
end;

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


	Solarisation = 215

Solarisation = 127	Solarisation = 63

procedure TForm1.Button5Click(Sender: TObject); 
var 
  b: TBitmap; 
begin 
  b := TBitmap.create; 
  b.loadfromfile('d:\bilder\auto.bmp'); 
  canvas.draw(10, 10, b); 
  Relief(b, nil, clred, 100, 215, true); 
  canvas.draw(b.width + 20, 10, b); 
  b.free; 
end;

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

procedure TForm1.Button9Click(Sender: TObject); 
var 
  b, m: TBitmap; 
begin 
  b := TBitmap.create; 
  m := TBitmap.create; 
  b.loadfromfile('d:\bilder\frau.bmp'); 
  m.loadfromfile('d:\bilder\muster.bmp'); 
  canvas.draw(10, 10, b); 
  Relief(b, m, clsilver, 180, 215, false); 
  canvas.draw(b.width + 20, 10, b); 
  m.free; 
  b.free; 
end;