DBR Delphi-Ecke

// Getestet mit D4 unter XP

// Querverweis: Farbschattierungen ersetzen

// Variante 1: Filter

// Wenn man Bitmaps einfärben oder tönen will, geht man am Einfachsten
// das Bild Pixel für Pixel durch und addiert jeweils einige Prozent der
// RGB-Werte des erwarteten Farbstiches. Allerdings wird das Bild dadurch
// insgesamt aufgehellt und bei bereits hellen Stellen bringt das Ganze meist
// nicht den erwarteten Erfolg, da beispielsweise die Farbe "Weiß" schon die
// größtmöglichen RGB-Werte hat und nichts mehr addiert werden kann.
// Deshalb habe ich mir einen Filter einfallen lassen, der über einen einfachen
// Korrekturwert die Sache behebt, und bei Bedarf an- und abgeschaltet werden
// kann. Das Ergebnis zeigt das folgende Testbild. Bitte achten Sie besonders auf
// den Graustufenkörper sowie auf die Farben "Weiß" und "Gelb" des Farbstreifens.

Testbid

Farbe = clFuchsia
Filter = False

Farbe = clFuchsia
Filter = True

type  
  aob = array[0..2] of Byte;  
  
procedure Kolorieren(Source, Dest: TBitmap; Farbe: TColor;  
  Intensiv: Byte; Filter: boolean);  
var  
  p: ^aob;  
  Divi: word;  
  hlp: TBitmap;  
  korr: Double;  
  h, w, x: Integer;  
  aos: array[0..2] of Double;  
  
  procedure rech(i: integer; s: Double);  
  var h: Integer;  
  begin  
    h := Trunc((p^[i] + p^[i] * (s - korr)) / 2);  
    if h > 255 then p^[i] := 255  
    else if h < 0 then p^[i] := 0  
    else p^[i] := Byte(h);  
  end;  
  
begin  
  hlp := TBitmap.create;  
  hlp.pixelformat := pf24bit;  
  hlp.width := Source.width;  
  hlp.height := Source.height;  
  hlp.canvas.draw(0, 0, Source);  
  Divi := 1084 - Intensiv * 4;  
  Farbe := ColorToRGB(Farbe);  
  aos[0] := getbvalue(Farbe) / Divi + 1;  
  aos[1] := getgvalue(Farbe) / Divi + 1;  
  aos[2] := getrvalue(Farbe) / Divi + 1;  
  korr := ord(Filter) * ((aos[0] + aos[1] + aos[2]) / 9);  
  for h := 0 to hlp.Height - 1 do begin  
    p := hlp.ScanLine[h];  
    for w := 0 to hlp.Width - 1 do begin  
      for x := 0 to 2 do rech(x, aos[x]);  
      Inc(p);  
    end;  
  end;
  Dest.pixelformat := pf24bit;
  Dest.width := Source.width;  
  Dest.height := Source.height;  
  Dest.canvas.draw(0, 0, hlp);  
  hlp.free;  
end;  
  
  
// Beispielaufruf (siehe obige Abbildung) 
procedure TForm1.Button2Click(Sender: TObject);  
var bm: TBitmap;  
begin  
  bm := TBitmap.Create;  
  kolorieren(image1.Picture.bitmap, bm, clFuchsia, 215, false);  
  canvas.draw(image1.width + 5 + image1.left, image1.top, bm);  
  kolorieren(image1.Picture.bitmap, bm, clFuchsia, 215, true);  
  canvas.draw((image1.width + 5) * 2 + image1.left, image1.top, bm);  
  bm.free;  
end;

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

// Variante 2: Ohne Filter

// Wer auf den Filter verzichten kann, nimmt den folgenden (einfachen) Code,
// dessen Färbung nicht ganz so intensiv ist.

Testbid

Farbe = clLime
Intensiv = 100

procedure einfaerben(src, dst: TBitmap; Farbe: TColor; Intensiv: Byte); 
var 
  ps, pd: PBytearray; 
  x, y, b3, diff: integer; 
  r, g, b: byte; 
begin 
  src.pixelformat := pf24bit; 
  dst.pixelformat := pf24bit; 
  dst.width := src.width; 
  dst.height := src.height; 
  Farbe := ColorToRGB(Farbe); 
  r := getrvalue(Farbe); 
  g := getgvalue(Farbe); 
  b := getbvalue(Farbe); 
  b3 := src.Width * 3; 
  diff := 255 - Intensiv; 
  for y := 0 to src.height - 1 do 
  begin 
    x := 0; 
    ps := src.scanline[y]; 
    pd := dst.scanline[y]; 
    while x < b3 do 
    begin 
      pd[x] := (ps[x] * diff + ps[x] * b * intensiv shr 8) shr 8; 
      pd[x + 1] := (ps[x + 1] * diff + ps[x + 1] * g * intensiv shr 8) shr 8; 
      pd[x + 2] := (ps[x + 2] * diff + ps[x + 2] * r * intensiv shr 8) shr 8; 
      Inc(x, 3); 
    end; 
  end; 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button8Click(Sender: TObject); 
var bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  einfaerben(Image3.picture.bitmap, bm, clLime, 100); 
  canvas.draw(Image3.boundsrect.right + 10, Image3.top, bm); 
  bm.free; 
end;

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

// Variante 3: Tönung über TRGBTriple

// Weiche Tönung. Ähnelt der Variante 2.

Testbid

Farbe = clRed
Prozent = 50

type 
  Prozent = 0..100; 
 
var 
  bmp: TBitmap; 
 
procedure farb(src, dst: TBitmap; Farbe: TColor; proz: Prozent); 
type 
  TLine = array[0..21845] of TRGBTriple; 
  PLine = ^TLine; 
var 
  w, h: integer; 
  r, g, b, t, p, d: Byte; 
  line1, line2: PLine; 
begin 
  src.pixelformat := pf24bit; 
  dst.pixelformat := pf24bit; 
  t := high(proz); 
  p := proz div 2; 
  d := t - p; 
  farbe := colorToRGB(farbe); 
  r := getrvalue(farbe); 
  g := getgvalue(farbe); 
  b := getbvalue(farbe); 
  for h := 0 to src.Height - 1 do begin 
    line1 := src.ScanLine[h]; 
    line2 := dst.ScanLine[h]; 
    for w := 0 to src.Width - 1 do begin 
      line2[w].rgbtRed := trunc(line1[w].rgbtRed / t * d + r / t * p); 
      line2[w].rgbtGreen := trunc(line1[w].rgbtGreen / t * d + g / t * p); 
      line2[w].rgbtBlue := trunc(line1[w].rgbtBlue / t * d + b / t * p); 
    end; 
  end; 
end; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bmp := TBitmap.create; 
  bmp.loadfromfile('c:\bmp1.bmp'); 
  Image1.picture.bitmap.loadfromfile('c:\bmp1.bmp'); 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bmp.free; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  farb(bmp, Image1.picture.bitmap, clRed, 50); 
  Image1.Refresh; 
end;

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

// Variante 4: Vollfarbe

// Die Bilder bestehen nur noch aus Tönen ein und der selben Farbe.

Testbid

Farbe = clBlue

Farbe = $80FF

procedure faerben(src, dst: TBitmap; Farbe: TColor); 
var 
  p: PBytearray; 
  x, y, b3: integer; 
  r, g, b: byte; 
begin 
  src.pixelformat := pf24bit; 
  dst.pixelformat := pf24bit; 
  dst.width := src.width; 
  dst.height := src.height; 
  dst.canvas.draw(0, 0, src); 
  Farbe := ColorToRGB(Farbe); 
  r := getrvalue(Farbe); 
  g := getgvalue(Farbe); 
  b := getbvalue(Farbe); 
  b3 := src.Width * 3; 
  for y := 0 to src.height - 1 do 
  begin 
    x := 0; 
    p := dst.scanline[y]; 
    while x < b3 do 
    begin 
      p[x] := b * p[x] div 255; 
      p[x + 1] := g * p[x + 1] div 255; 
      p[x + 2] := r * p[x + 2] div 255; 
      Inc(x, 3); 
    end; 
  end; 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button8Click(Sender: TObject); 
var bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  faerben(Image3.picture.bitmap, bm, clBlue); 
  canvas.draw(100, 0, bm); 
  bm.free; 
end; 
 
procedure TForm1.Button9Click(Sender: TObject); 
var bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  faerben(Image3.picture.bitmap, bm, $80FF); 
  canvas.draw(500, 0, bm); 
  bm.free; 
end;

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

// Variante 5: Sepia

// Der Effekt Sepia simuliert den traditionellen Dunkelkammer-Effekt,
// den professionelle Fotografen erzielen, wenn Sie mit Chemikalien
// und Entwicklungsprozessen arbeiten, welche Graustufenbilder einfärben.
// Normalerweise verwendet man für die Variable "farbvariante" den
// Wert "1", was den typisch bräunlich-gelblichen Farbton ergibt.
// Zusätzlich habe ich aber auch noch die Werte "2" bis "5" eingearbeitet.

Testbid

Stufe = 100
Farbvariante = 1

Stufe = 100
Farbvariante = 5

procedure sepia(Source, Dest: TBitmap; stufe, farbvariante: byte); 
var 
  r, g, b, h, w, w3, st, st3: integer; 
  p: PBytearray; 
  hlp: TBitmap; 
begin 
  hlp := TBitmap.create; 
  hlp.pixelformat := pf24bit; 
  hlp.width := Source.width; 
  hlp.height := Source.height; 
  hlp.canvas.draw(0, 0, Source); 
  st3 := round(stufe * 0.444); 
  st := round(stufe * 0.167); 
  w3 := hlp.width * 3 - 1; 
  for h := 0 to hlp.height - 1 do begin 
    w := 0; 
    p := hlp.scanline[h]; 
    while w < w3 do begin 
      b := (p[w] + p[w + 1] + p[w + 2]) div 3; 
      r := b + st3; 
      g := b + st; 
      if r > 255 then r := 255; 
      if g > 255 then g := 255; 
      case farbvariante of 
        0: ; 
        1: begin 
            p[w] := b; 
            p[w + 1] := g; 
            p[w + 2] := r; 
          end; 
        2: begin 
            p[w] := r; 
            p[w + 1] := g; 
            p[w + 2] := b; 
          end; 
        3: begin 
            p[w] := g; 
            p[w + 1] := b; 
            p[w + 2] := r; 
          end; 
        4: begin 
            p[w] := g; 
            p[w + 1] := r; 
            p[w + 2] := b; 
          end; 
        5: begin 
            p[w] := r; 
            p[w + 1] := b; 
            p[w + 2] := g; 
          end; 
      else begin 
          p[w] := b; 
          p[w + 1] := b; 
          p[w + 2] := b; 
        end; 
      end; 
      inc(w, 3); 
    end; 
  end; 
  Dest.pixelformat := pf24bit;
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.canvas.draw(0, 0, hlp); 
  hlp.free; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject);
var bm: TBitmap; 
begin 
  bm := TBitmap.Create; 
  sepia(image1.picture.bitmap, bm, 100, 1); 
  canvas.draw(image1.width + 5 + image1.left, image1.top, bm); 
  bm.free; 
end;

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

// Variante 6: Schwarz-Farb-Technik

// ab einer bestimmten Helligkeitsstufe wird die entsprechende Stelle im
// Bild schwarz eingefärbt oder als abgedunkelte Farbe dargestellt.

Testbid

intensiv = 150
Farbe = clGreen

intensiv = 195
Farbe = clMaroon


var 
  graugrenze: integer = 95; 
  weissgrenze: integer = 242; 
  schwarzgrenze: integer = 80; 
 
procedure schwrzfrb(Source, Dest: TBitmap; farbe: TColor; intensiv: byte); 
var 
  k, x, y, r, g, b, w: integer; 
  p: PBytearray; 
  hlp: TBitmap; 
  function rech(i, j: integer): integer; 
  asm 
    add eax, edx 
    sub eax, $40 
    cmp eax, 0 
    jge @weiter 
    xor eax, eax 
    jmp @fertig 
   @weiter: 
    cmp eax, $FF 
    jle @fertig 
    mov eax, $FF 
    @fertig: 
  end; 
begin 
  hlp := TBitmap.create; 
  hlp.pixelformat := pf24bit; 
  hlp.width := Source.width; 
  hlp.height := Source.height; 
  hlp.canvas.draw(0, 0, Source); 
  farbe := colortorgb(farbe); 
  r := getrvalue(farbe) * intensiv shr 8; 
  g := getgvalue(farbe) * intensiv shr 8; 
  b := getbvalue(farbe) * intensiv shr 8; 
  w := hlp.width * 3; 
  for y := 0 to pred(hlp.height) do begin 
    p := hlp.scanline[y]; 
    x := 0; 
    while x < w do begin 
      k := (p[x] + p[x + 1] + p[x + 2]) div 3; 
      if k > weissgrenze then begin 
        p[x] := rech(290, b); 
        p[x + 1] := rech(290, g); 
        p[x + 2] := rech(290, r); 
      end else if k < schwarzgrenze then begin 
        p[x] := 0; 
        p[x + 1] := 0; 
        p[x + 2] := 0; 
      end else if k < graugrenze then begin 
        p[x] := rech(60, b); 
        p[x + 1] := rech(60, g); 
        p[x + 2] := rech(60, r); 
      end else begin 
        p[x] := rech(k, b); 
        p[x + 1] := rech(k, g); 
        p[x + 2] := rech(k, r); 
      end; 
      inc(x, 3); 
    end; 
  end; 
  Dest.pixelformat := pf24bit; 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.canvas.draw(0, 0, hlp); 
  hlp.free; 
end; 
 
 
// Beispielaufruf 
 
procedure TForm1.Button3Click(Sender: TObject); 
begin 
  schwrzfrb(Image1.picture.bitmap, Image1.picture.bitmap, clGreen, 150); 
end;

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

// Variante 7: one color gray

// Eine der 3 RGB-Farben wird betont, alle anderen Farben in Grau gewandelt.

Testbid

intensiv = 92
Farbe = Rot

intensiv = 135
Farbe = Gruen

type 
  RoGrBl = (rot, gruen, blau); 
 
procedure onecolorgray(Source, Dest: TBitmap; farbe: RoGrBl; intensiv: byte); 
var 
  x, y, b3: integer; 
  p: PBytearray; 
  procedure grau; 
  begin 
    p[x] := (p[x] + p[x + 1] + p[x + 2]) div 3; 
    p[x + 1] := p[x]; 
    p[x + 2] := p[x]; 
  end; 
begin 
  dest.pixelformat := pf24bit; 
  dest.width := source.width; 
  dest.height := source.height; 
  dest.canvas.draw(0, 0, source); 
  b3 := dest.width * 3; 
  for y := 0 to dest.height - 1 do begin 
    x := 0; 
    p := dest.scanline[y]; 
    while x < b3 do begin 
      case farbe of 
        rot: if (p[x + 2] + intensiv > p[x] + 128) and (p[x + 2] <> p[x]) 
          and (p[x + 2] + intensiv > p[x + 1] + 128) and (p[x + 2] <> p[x + 1]) 
            then begin 
            p[x] := (255 - p[x + 2]) div 2; 
            if p[x] > p[x + 2] then begin 
              p[x + 1] := p[x + 2]; 
              p[x + 2] := p[x]; 
              p[x] := p[x + 1]; 
            end else 
              p[x + 1] := p[x]; 
          end else grau; 
        gruen: if (p[x + 1] + intensiv > p[x] + 128) and (p[x + 1] <> p[x]) 
          and (p[x + 1] + intensiv > p[x + 2] + 128) and (p[x + 1] <> p[x + 2]) 
            then begin 
            p[x] := (255 - p[x + 1]) div 2; 
            if p[x] > p[x + 1] then begin 
              p[x + 2] := p[x + 1]; 
              p[x + 1] := p[x]; 
              p[x] := p[x + 2]; 
            end else 
              p[x + 2] := p[x]; 
          end else grau; 
      else if (p[x] + intensiv > p[x + 2] + 128) and (p[x + 2] <> p[x]) 
        and (p[x] + intensiv > p[x + 1] + 128) and (p[x + 1] <> p[x]) 
        then begin 
        p[x + 1] := (255 - p[x]) div 2; 
        if p[x + 1] > p[x] then begin 
          p[x + 2] := p[x]; 
          p[x] := p[x + 1]; 
          p[x + 1] := p[x + 2]; 
        end else 
          p[x + 2] := p[x + 1]; 
      end else grau; 
      end; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
procedure TForm1.Button5Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  onecolorgray(image1.picture.bitmap, bm, rot, 92); 
  canvas.draw(image1.left + image1.width + 5, image1.top, bm); 
  bm.free; 
end;

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

// Variante 8: Bonbon-Farbe

// Durch Überbetonen aller Kanäle werden unnatürliche Farben erzeugt.

Testbid

Stufe = 175

procedure bonbon(src: TGraphic; dst: TBitmap; stufe: byte); 
var 
  x, y, b3: integer; 
  p: PBytearray; 
  b, c: byte; 
  function vergl: byte; 
  begin 
    result := ord((p[x + 2] > p[x + 1]) and (p[x + 2] > p[x])) or 
      (ord((p[x + 1] > p[x + 2]) and (p[x + 1] > p[x])) shl 1) or 
      (ord((p[x] > p[x + 1]) and (p[x] > p[x + 2])) shl 2); 
  end; 
  function rech(b, s: byte): byte; 
  var 
    h: integer; 
  begin 
    if b < 32 then result := b else begin 
      h := b + s; 
      if h < 0 then result := 0 
      else if h > 255 then result := 255 
      else result := h; 
    end; 
  end; 
begin 
  if not Assigned(src) then exit; 
  dst.width := src.width; 
  dst.height := src.height; 
  dst.pixelformat := pf24bit; 
  dst.canvas.draw(0, 0, src); 
  b3 := dst.width * 3; 
  for y := 0 to dst.height - 1 do begin 
    x := 0; 
    p := dst.scanline[y]; 
    while x < b3 do begin 
      b := vergl; 
      c := ord(b = 0); 
      if b in [0, 1] then 
        p[x + 2] := rech(p[x + 2], trunc(stufe * (0.5 - c * 0.4))); 
      if b in [0, 2] then p[x + 1] := rech(p[x + 1], trunc(stufe * 0.1)); 
      if b in [0, 4] then p[x] := rech(p[x], trunc(stufe * (0.4 - c * 0.3))); 
      inc(x, 3); 
    end; 
  end; 
end; 
 
// Beispiel 
 
procedure TForm1.Button4Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  bonbon(Image1.picture.graphic, bm, 175); 
  canvas.draw(Image1.left + Image1.width + 5, Image1.top, bm); 
  bm.free; 
end;

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

// Variante 9: Blassfärben

Testbid

Stufe = 50
Farbe = $404080

Stufe = 50
Farbe = $804040

type 
  staerke = 0..100; 
 
procedure grad(dst, src: TBitmap; Farbe: TColor; Stufe: staerke); 
var x, y, x3, r, g, b: integer; 
  p, p2: pbytearray; 
  function rechnen(bf, bp: byte): byte; 
  var h: integer; 
  begin 
    h := abs(trunc(Stufe * bf / (bp + 0.01) * 0.333)); 
    if h <= 0 then result := 255 
    else if h >= 255 then result := 0 
    else result := 255 - h; 
  end; 
begin 
  inc(Stufe, 155); 
  dst.pixelformat := pf24bit; 
  src.pixelformat := pf24bit; 
  Farbe := ColorToRGB(Farbe); 
  r := 128 - GetRValue(Farbe) div 2; 
  g := 128 - GetGValue(Farbe) div 2; 
  b := 128 - GetBValue(Farbe) div 2; 
  for y := 0 to dst.height - 1 do begin 
    p := dst.scanline[y]; 
    p2 := src.scanline[y]; 
    for x := 0 to dst.width - 1 do begin 
      x3 := x * 3; 
      if (p2[x3] <> 255) or (p2[x3 + 1] <> 255) or (p2[x3 + 2] <> 255) 
        then begin 
        p[x3] := rechnen(b, p2[x3]); 
        p[x3 + 1] := rechnen(g, p2[x3 + 1]); 
        p[x3 + 2] := rechnen(r, p2[x3] + 2); 
      end else begin 
        p[x3] := 238; 
        p[x3 + 1] := 238; 
        p[x3 + 2] := 238; 
      end; 
    end; 
  end; 
end; 
 
 
// Beispiel 
 
procedure TForm1.Button2Click(Sender: TObject); 
var b: TBitmap; 
begin 
  b := TBitmap.create; 
  b.width := image1.width; 
  b.height := image1.height; 
  Grad(b, Image1.picture.bitmap, $404080, 50); 
  canvas.draw(10, 10, b); 
  Grad(b, Image1.picture.bitmap, $804040, 50); 
  canvas.draw(200, 10, b); 
  b.free; 
end;

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

// Variante 10: Nachtstimmung

Testbid

Stufe = 100
Farbe = clBlue

Stufe = 100
Farbe = clPurple

type 
  staerke = 0..100; 
 
procedure Nacht(dst, src: TBitmap; Farbe: TColor; stufe: staerke); 
const dv = 127; 
var x, y, x3, r, g, b, f: integer; 
  p, p2: pbytearray; 
  px1, px2, px3: Byte; 
  function rechnen(pb: byte): byte; 
  var h: integer; 
  begin 
    h := trunc(pb * (f - dv * 1.5) / dv - dv); 
    if h < 0 then result := 0 
    else if h > 255 then result := 255 
    else result := h; 
  end; 
begin 
  src.pixelformat := pf24bit; 
  dst.pixelformat := pf24bit; 
  dst.width := src.width; 
  dst.height := src.height; 
  Farbe := ColorToRGB(Farbe); 
  r := dv + GetRValue(Farbe) div 2; 
  g := dv + GetGValue(Farbe) div 2; 
  b := dv + GetBValue(Farbe) div 2; 
  with dst.canvas do begin 
    brush.color := 0; 
    fillrect(cliprect); 
  end; 
  inc(stufe, 155); 
  for y := 0 to dst.height - 1 do begin 
    p := dst.scanline[y]; 
    p2 := src.scanline[y]; 
    for x := 0 to dst.width - 1 do begin 
      x3 := x * 3; 
      f := p2[x3] + p2[x3 + 1] + p2[x3 + 2]; 
      px1 := rechnen(p2[x3]); 
      px2 := rechnen(p2[x3 + 1]); 
      px3 := rechnen(p2[x3 + 2]); 
      p[x3] := (px1 * b * stufe) shr 16; 
      p[x3 + 1] := (px2 * g * stufe) shr 16; 
      p[x3 + 2] := (px3 * r * stufe) shr 16; 
    end; 
  end; 
end; 
 
// Beispiel 
 
procedure TForm1.Button2Click(Sender: TObject); 
var b: TBitmap; 
begin 
  b := TBitmap.create; 
  Nacht(b, Image1.picture.bitmap, clBlue, 100); 
  canvas.draw(10, 10, b); 
  Nacht(b, Image1.picture.bitmap, clPurple, 100); 
  canvas.draw(200, 10, b); 
  b.free; 
end;