DBR Delphi-Ecke

// Wenn man in Delphi ein Bitmap mit einer Farbtiefe von 24 oder 32 Bit einfach
// mittels bitmap.pixelformat := pf8bit in ein Paletten-Bitmap mit 256 Farben umwandelt,
// besitzt das Ergebnis kein definiertes Aussehen, da die Palette noch nicht mit den
// entsprechenden Farben gefüllt ist. Das Problem kann man auf verschiedene Art und Weise
// lösen. Beispielsweise kann man eine feste Palette verwenden, welche die gängigsten
// Farben enthält. Dabei kann es aber zu Falschfarben kommen, da die Palette nicht speziell
// für das Bild angepasst ist. Oder man errechnet zu einer Teilpalette Mittelwerte von
// Farbbereichen. Oder man benutzt die Möglichkeit, das System eine Halfton- Palette
// erzeugen zu lassen und mit StretchBlt ein gedithertes Bild zu erstellen. Oder man
// nutzt die Möglichkeiten eines JPG. Als Alternative habe ich mir das Auslesen von
// einzelnen Punkten in Raster-Art ausgedacht. Die Ergebnisse sehen Sie hier:
// (Ihre Grafikkarte muss mindestens auf 16 Bit Farbtiefe eingestellt sein,
// um die Unterschiede richtig sehen zu können)

TrueColor Vorlage

feste Palette	Teilpalette	Halftone-Palette	JPeg-Methode	Raster-Methode


TrueColor Vorlage

feste Palette	Teilpalette	Halftone-Palette	JPeg-Methode	Raster-Methode

// Getestet mit D4 unter Win98

// 1. Feste Palette
// Nur für wenige Bilder ausreichend.

var 
  f256: array[0..255] of TColor = ( 
    $000000, $000080, $008000, $008080, $800000, $800080, $808000, $C0C0C0, 
    $C0DCC0, $F0CAA6, $00002C, $000056, $000087, $0000C0, $002C00, $002C2C, 
    $002C56, $002C87, $002CC0, $002CFF, $005600, $00562C, $005656, $005687, 
    $0056C0, $0056FF, $008700, $00872C, $008756, $008787, $0087C0, $0087FF, 
    $00C000, $00C02C, $00C056, $00C087, $00C0C0, $00C0FF, $00FF2C, $00FF56, 
    $00FF87, $00FFC0, $2C0000, $2C002C, $2C0056, $2C0087, $2C00C0, $2C00FF, 
    $2C2C00, $2C2C2C, $2C2C56, $2C2C87, $2C2CC0, $2C2CFF, $2C5600, $2C562C, 
    $2C5656, $2C5687, $2C56C0, $2C56FF, $2C8700, $2C872C, $2C8756, $2C8787, 
    $2C87C0, $2C87FF, $2CC000, $2CC02C, $2CC056, $2CC087, $2CC0C0, $2CC0FF, 
    $2CFF00, $2CFF2C, $2CFF56, $2CFF87, $2CFFC0, $2CFFFF, $560000, $56002C, 
    $560056, $560087, $5600C0, $5600FF, $562C00, $562C2C, $562C56, $562C87, 
    $562CC0, $562CFF, $565600, $56562C, $565656, $565687, $5656C0, $5656FF, 
    $568700, $56872C, $568756, $568787, $5687C0, $5687FF, $56C000, $56C02C, 
    $56C056, $56C087, $56C0C0, $56C0FF, $56FF00, $56FF2C, $56FF56, $56FF87, 
    $56FFC0, $56FFFF, $870000, $87002C, $870056, $870087, $8700C0, $8700FF, 
    $872C00, $872C2C, $872C56, $872C87, $872CC0, $872CFF, $875600, $87562C, 
    $875656, $875687, $8756C0, $8756FF, $878700, $87872C, $878756, $878787, 
    $8787C0, $8787FF, $87C000, $87C02C, $87C056, $87C087, $87C0C0, $87C0FF, 
    $87FF00, $87FF2C, $87FF56, $87FF87, $87FFC0, $87FFFF, $C00000, $C0002C, 
    $C00056, $C00087, $C000C0, $C000FF, $C02C00, $C02C2C, $C02C56, $C02C87, 
    $C02CC0, $C02CFF, $C05600, $C0562C, $C05656, $C05687, $C056C0, $C056FF, 
    $C08700, $C0872C, $C08756, $C08787, $C087C0, $C087FF, $C0C000, $C0C02C, 
    $C0C056, $C0C087, $C0C0FF, $C0FF00, $C0FF2C, $C0FF56, $C0FF87, $C0FFC0, 
    $C0FFFF, $FF002C, $FF0056, $FF0087, $FF00C0, $FF2C00, $FF2C2C, $FF2C56, 
    $FF2C87, $FF2CC0, $FF2CFF, $FF5600, $FF562C, $FF5656, $FF5687, $FF56C0, 
    $FF56FF, $FF8700, $FF872C, $FF8756, $FF8787, $FF87C0, $FF87FF, $FFC000, 
    $FFC02C, $FFC056, $FFC087, $FFC0C0, $FFC0FF, $FFFF2C, $FFFF56, $FFFF87, 
    $FFFFC0, $111111, $181818, $1E1E1E, $252525, $343434, $3C3C3C, $444444, 
    $4D4D4D, $5F5F5F, $696969, $727272, $7D7D7D, $929292, $9D9D9D, $A8A8A8, 
    $B4B4B4, $CCCCCC, $D8D8D8, $E5E5E5, $F2F2F2, $556DFF, $AA6DFF, $FF6DFF, 
    $0092FF, $5592FF, $AA92FF, $FF92FF, $00B6FF, $55B6FF, $F0FBFF, $A4A0A0, 
    $808080, $0000FF, $00FF00, $00FFFF, $FF0000, $FF00FF, $FFFF00, $FFFFFF); 
 
{$R-} 
 
procedure Fest(Source, Dest: TBitmap); 
var 
  lPal: PLogpalette; 
  i: integer; 
  hlp: TBitmap; 
begin 
  hlp := TBitmap.create; 
  hlp.assign(Source); 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf8bit; 
  lpal := AllocMem(sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256); 
  lpal.palVersion := $300; 
  lpal.palNumEntries := 256; 
  for i := 0 to 255 do 
    lpal.palPalEntry[i] := TPaletteentry(f256[i]); 
  Dest.palette := CreatePalette(lpal^); 
  Dest.canvas.draw(0, 0, hlp); 
  FreeMem(lpal); 
  hlp.free; 
end; 

 
// Beispielaufruf 
 
procedure TForm1.Button6Click(Sender: TObject); 
var b: TBitmap; 
begin 
  b := TBitmap.create; 
  fest(image1.picture.bitmap, b); 
  canvas.draw(10, 10, b); 
  b.free; 
end;

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

// 2. Teilpalette
// Für manche Bilder (speziell für Icons) ausreichend, jedoch nicht immer für Porträts.

var 
  ff: array[0..59] of TColor = ( 
    $000000, $000080, $008000, $008080, $800000, $9DDBFF, 
    $800080, $808000, $C0C0C0, $C0DCC0, $F0CAA6, $CC6600, 
    $F0FBFF, $A4A0A0, $808080, $0000FF, $00FF00, $FFCCFF, 
    $00FFFF, $FF0000, $FF00FF, $FFFF00, $FFFFFF, $009900, 
    $006699, $0099CC, $00CCFF, $00FFFF, $99FFFF, $66CCFF, 
    $3399FF, $4B79FF, $0033FF, $000099, $663333, $993300, 
    $D78300, $FF9900, $DE9A3E, $FFCC99, $FFE2B4, $FFFFDE, 
    $FFCCCC, $FF9999, $CC6666, $CC9999, $996666, $006600, 
    $33CC66, $66FF99, $CCFFCC, $161D48, $B9C4E0, $212A5C, 
    $7283A4, $3161B5, $4A79D6, $2945C6, $7BA2F7, $CEDFFF); 
 
procedure mittelwert(Source, Dest: TBitmap); 
const k = 24; 
var 
  lPal: PLogpalette; 
  x, y, x3, i: integer; 
  r, g, b: byte; 
  p: PBytearray; 
  pe: array[0..255] of TPaletteEntry; 
  function schonda: boolean; 
  var z: integer; 
  begin 
    result := false; 
    for z := 1 to i do 
      if 
        (abs(r - pe[z].peRed) < 3) and 
        (abs(g - pe[z].peGreen) < 4) and 
        (abs(b - pe[z].peBlue) < 2) 
        then begin 
        result := true; 
        break; 
      end; 
  end; 
begin 
  zeromemory(@pe, sizeof(pe)); 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf24bit; 
  Dest.canvas.draw(0, 0, Source); 
  for x := 0 to high(ff) do begin 
    pe[x].peRed := getrvalue(ff[x]); 
    pe[x].peGreen := getgvalue(ff[x]); 
    pe[x].peBlue := getbvalue(ff[x]); 
  end; 
  i := length(ff); 
  for y := 0 to Dest.height - 1 do begin 
    p := dest.scanline[y]; 
    for x := 0 to Dest.width - 1 do begin 
      x3 := x * 3; 
      b := ((p[x3] + 1) div k) * k; 
      g := ((p[x3 + 1] + 1) div k) * k; 
      r := ((p[x3 + 2] + 1) div k) * k; 
      if not schonda then begin 
        pe[i].peRed := r; 
        pe[i].peGreen := g; 
        pe[i].peBlue := b; 
        inc(i); 
      end; 
      if i > 255 then break; 
    end; 
    if i > 255 then break; 
  end; 
  Dest.pixelformat := pf8bit; 
  lpal := AllocMem(sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256); 
  lpal.palVersion := $300; 
  lpal.palNumEntries := 256; 
  for x := 0 to 255 do 
    lpal.palPalEntry[x] := pe[x]; 
  Dest.palette := CreatePalette(lpal^); 
  FreeMem(lpal); 
  Dest.canvas.draw(0, 0, source); 
end;

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

// 3. Halftone-Palette
// Ergibt ein gedithertes Bild.

procedure Halftone(Source, Dest: TBitmap); 
var 
  HPal: HPalette; 
begin 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.pixelformat := pf8bit; 
  SetStretchBltMode(Dest.canvas.handle, STRETCH_HALFTONE); 
  HPal := CreateHalftonePalette(Source.canvas.handle); 
  SelectPalette(Dest.canvas.handle, HPal, true); 
  RealizePalette(Dest.canvas.handle); 
  stretchblt(Dest.canvas.handle, 0, 0, Dest.width, Dest.height, 
    Source.canvas.handle, 0, 0, Source.width, Source.height, srccopy); 
  deleteobject(HPal); 
end;

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

// 4. JPeg-Methode
// Es muss die Unit "jpeg" mit in das Programm eingebunden werden.
// Die erzeugten Bilder sind zum Umwandeln in GIF untauglich, da
// homogene Farbflächen in Artefakte zerlegt wurden. Außerdem versagt
// die Methode bei sehr großen Bildern.

uses JPeg; 
 
procedure wandeln(Source, Dest: TBitmap); 
var 
  jp: TJpegImage; 
begin 
  jp := TJPegImage.create; 
  jp.assign(Source); 
  jp.JPEGNeeded; 
  jp.CompressionQuality := 100; 
  jp.Performance := jpBestQuality; 
  jp.smoothing := true; 
  jp.pixelformat := jf8Bit; 
  jp.DibNeeded; 
  Dest.pixelformat := pf8bit; 
  Dest.assign(jp); 
  jp.free; 
end;

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

// 5. Raster-Methode
// Neben 31 (30 + schwarz) fest vorgegebenen Farben, werden die Farbinformationen
// von 225 rasterartig über das Bild verteilten Punkten ausgelesen.

var 
  f256: array[0..255] of TColor; 
 
procedure fillPalette(bm: TBitmap); 
var 
  x, y, z, i, j, br, hc, m3, a, b: integer; 
  p: PBytearray; 
  c: TColor; 
  function schonda: boolean; 
  var k: integer; 
  begin 
    result := false; 
    for k := 0 to z - 1 do 
      if (abs(f256[k] shr 16 - p[x + a]) < 9) and 
        (abs((f256[k] and $FF00) shr 8 - p[x + a + 1]) < 11) and 
        (abs((f256[k] and $FF) - p[x + a + 2]) < 10) 
        then begin 
        result := true; 
        break; 
      end; 
  end; 
begin 
  zeromemory(@f256, sizeof(f256)); 
  f256[0] := clwhite; f256[1] := clmaroon; f256[2] := clgreen; 
  f256[3] := clolive; f256[4] := clnavy; f256[5] := clpurple; 
  f256[6] := clteal; f256[7] := clsilver; f256[8] := $C0DCC0; 
  f256[9] := $F0CAA6; f256[10] := $F0FBFF; f256[11] := $A4A0A0; 
  f256[12] := clgray; f256[13] := clred; f256[14] := cllime; 
  f256[15] := clyellow; f256[16] := clblue; f256[17] := clfuchsia; 
  f256[18] := claqua; f256[19] := $0064E1; f256[20] := $197DC8; 
  f256[21] := $3296AF; f256[22] := $4BAF96; f256[23] := $64C87D; 
  f256[24] := $7DE164; f256[25] := $96004B; f256[26] := $AF1932; 
  f256[27] := $C83219; f256[28] := $E14B00; f256[29] := $433CC6; 
  z := 30; 
  if (bm.width * bm.height < 226) then begin 
    for y := 0 to bm.height - 1 do begin 
      p := bm.scanline[y]; 
      for x := 0 to bm.width - 1 do begin 
        m3 := x * 3; 
        f256[z + x + y * bm.width] := (p[m3] shl 16) or (p[m3 + 1] shl 8) 
          or p[m3 + 2]; 
      end; 
    end; 
  end else begin 
    j := bm.height div 15; 
    if j < 1 then j := 1; 
    i := bm.width div 15; 
    if i < 1 then i := 1; 
    br := i * 45; 
    hc := j * 15; 
    m3 := i * 3; 
    y := 0; 
    while y < hc do begin 
      x := 0; 
      p := bm.scanline[y]; 
      while x < br do begin 
        a := 0; 
        b := 0; 
        repeat 
          c := (p[x + a] shl 16) or (p[x + 1 + a] shl 8) or p[x + 2 + a]; 
          if not schonda then break; 
          inc(a, 3); 
          if (a >= m3) then begin 
            inc(b); 
            if (b >= j) then break; 
            a := 0; 
            p := bm.scanline[y + b]; 
          end; 
        until false; 
        f256[z] := c; 
        inc(z); 
        inc(x, m3); 
      end; 
      inc(y, j); 
    end; 
  end; 
end; 
 
{$R-} 
 
procedure Raster(Source, Dest: TBitmap); 
var 
  lPal: PLogpalette; 
  i: integer; 
begin 
  Dest.pixelformat := pf24bit; 
  Dest.width := Source.width; 
  Dest.height := Source.height; 
  Dest.canvas.draw(0, 0, Source); 
  fillPalette(Dest); 
  Dest.pixelformat := pf8bit; 
  lpal := AllocMem(sizeof(TLogPalette) + sizeof(TPaletteEntry) * 256); 
  lpal.palVersion := $300; 
  lpal.palNumEntries := 256; 
  for i := 0 to 255 do lpal.palPalEntry[i] := Tpaletteentry(f256[i]); 
  Dest.palette := CreatePalette(lpal^); 
  FreeMem(lpal); 
  Dest.canvas.draw(0, 0, Source); 
end; 
 
// Beispiel 
 
procedure TForm1.Button2Click(Sender: TObject); 
var b: TBitmap; 
begin 
  b := TBitmap.create; 
  raster(Image1.picture.bitmap, b); 
  canvas.draw(0, 0, b); 
  b.free; 
end;