type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure FormCreate(Sender: TObject); 
    procedure Button1Click(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure vorbereitung(filename: string; bilder: word); 
    procedure veraenderungen(b1, b2: TBitmap); 
    procedure speichern(b: TBitmap); 
    procedure opti(bilder: word; transparent, komplett: boolean); 
    procedure optimiere 
      (filename: string; BildAnzahl: word; transparent, komplett: boolean); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
type 
  T24 = packed array[0..2] of Byte; 
 
const 
  flag: byte = $FF; 
  NoCode: byte = 0; 
  MaxCount: byte = $FE; 
 
var 
  basis, hlp, bmp, sv: TBitmap; 
  r, g, b: Byte; 
  breit, fase, links, rechts, oben, unten: word; 
  fs: TFilestream; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  fs := nil; 
  sv := TBitmap.create; 
  bmp := TBitmap.create; 
  hlp := TBitmap.create; 
  basis := TBitmap.create; 
  basis.pixelformat := pf24bit; 
  hlp.pixelformat := pf24bit; 
  sv.pixelformat := pf24bit; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  bmp.free; 
  basis.free; 
  hlp.free; 
  sv.free; 
  if fs <> nil then 
    fs.free; 
end; 
 
function RLEC(b: TBitmap; dst: TStream): integer; 
var src: TMemorystream; 
  x, y, z: integer; 
  p: PByteArray; 
  function Compr24: Boolean; 
  var 
    zhln: Boolean; 
    Count: byte; 
    T24_2: packed array[0..1] of T24; 
    N24: T24; 
  begin 
    Result := false; 
    if (src.Size - src.Position < SizeOf(T24_2)) then exit; 
    src.ReadBuffer(T24_2, SizeOf(T24_2)); 
    src.Position := src.Position - SizeOf(T24_2); 
    if not comparemem(@T24_2[0], @T24_2[1], 3) then exit; 
    Result := true; 
    src.Position := src.Position + SizeOf(T24_2); 
    Count := High(T24_2) - Low(T24_2) + 1; 
    if (src.Size - src.Position >= SizeOf(N24)) then 
      repeat 
        src.ReadBuffer(N24, SizeOf(N24)); 
        zhln := comparemem(@T24_2[0], @N24, 3); 
        if zhln then Inc(Count) 
        else src.Position := src.Position - SizeOf(T24); 
      until (not zhln) or (Count >= MaxCount) or 
        (src.Size - src.Position < SizeOf(T24)); 
    dst.WriteBuffer(flag, SizeOf(flag)); 
    dst.WriteBuffer(Count, SizeOf(Count)); 
    dst.WriteBuffer(T24_2[0], SizeOf(T24_2[0])); 
  end; 
  procedure nocmpr; 
  var n: byte; 
  begin 
    if (src.Size - src.Position < SizeOf(byte)) then exit; 
    src.ReadBuffer(n, SizeOf(n)); 
    dst.WriteBuffer(n, SizeOf(n)); 
    if (n = flag) then dst.WriteBuffer(NoCode, SizeOf(NoCode)); 
  end; 
begin 
  src := TMemorystream.create; 
  for y := 0 to b.height - 1 do begin 
    p := b.scanline[y]; 
    for x := 0 to b.width - 1 do 
      for z := 0 to 2 do 
        src.writebuffer(p[x * 3 + z], 1); 
  end; 
  src.Position := 0; 
  while (src.Size - src.Position >= SizeOf(byte)) do 
    if not Compr24 then nocmpr; 
  result := dst.size; 
  src.free; 
end; 
 
procedure TForm1.vorbereitung(filename: string; bilder: word); 
var s: string; 
begin 
  if bmp.width * bmp.height * 3 > 1000000 
    then raise exception.create('Speicherbedarf zu groß'); 
  breit := bmp.width div bilder; 
  // bei Bedarf evtl. so etwas: 
  // bmp.TransparentColor := bmp.canvas.pixels[0, 0]; 
  r := GetRValue(bmp.TransparentColor); 
  g := GetGValue(bmp.TransparentColor); 
  b := GetBValue(bmp.TransparentColor); 
  basis.width := breit; 
  hlp.width := breit; 
  basis.height := bmp.height; 
  hlp.height := bmp.height; 
  basis.TransparentColor := bmp.TransparentColor; 
  sv.TransparentColor := bmp.TransparentColor; 
  hlp.TransparentColor := bmp.TransparentColor; 
  sv.transparent := true; 
  s := changefileext(filename, '.obs'); 
  fs := TFilestream.create(s, fmcreate or fmShareExclusive); 
  fase := 0; 
end; 
 
procedure TForm1.speichern(b: TBitmap); 
var w: word; 
  i, p1, p2: integer; 
  dst: TMemorystream; 
begin 
  if (b.width > maxword) or (b.height > maxword) 
    or (b.width < 1) or (b.height < 1) 
    then raise exception.create('Bildmaße fehlerhaft'); 
  dst := TMemorystream.create; 
  w := b.width; 
  fs.writebuffer(w, sizeof(w)); 
  w := b.height; 
  fs.writebuffer(w, sizeof(w)); 
  p1 := fs.position; 
  fs.writebuffer(i, sizeof(i)); 
  i := RLEC(b, dst); 
  dst.position := 0; 
  fs.copyfrom(dst, i); 
  dst.free; 
  p2 := fs.position; 
  fs.position := p1; 
  fs.writebuffer(i, sizeof(i)); 
  fs.position := p2; 
end; 
 
procedure TForm1.veraenderungen(b1, b2: TBitmap); 
var x, y, b3, x3: integer; 
  p1, p2: PBytearray; 
begin 
  b3 := b1.width * 3; 
  links := b1.width; 
  rechts := 0; 
  oben := b1.height; 
  unten := 0; 
  for y := 0 to b1.height - 1 do begin 
    x := 0; 
    p1 := b1.scanline[y]; 
    p2 := b2.scanline[y]; 
    while x < b3 do begin 
      if (p2[x] = p1[x]) and (p2[x + 1] = p1[x + 1]) and (p2[x + 2] = p1[x + 2]) 
        then begin 
        p2[x] := b; 
        p2[x + 1] := g; 
        p2[x + 2] := r; 
      end else begin 
        x3 := x div 3; 
        if x3 < links then links := x3; 
        if x3 > rechts then rechts := x3; 
        if y < oben then oben := y; 
        if y > unten then unten := y; 
      end; 
      inc(x, 3); 
    end; 
  end; 
end; 
 
procedure TForm1.opti(bilder: word; transparent, komplett: boolean); 
var i: integer; 
begin 
  i := bmp.width; 
  fs.writebuffer(i, sizeof(i)); 
  fs.writebuffer(bilder, sizeof(bilder)); 
  fs.writebuffer(transparent, sizeof(transparent)); 
  fs.writebuffer(komplett, sizeof(komplett)); 
  fs.writebuffer(r, 1); 
  fs.writebuffer(g, 1); 
  fs.writebuffer(b, 1); 
  with basis.Canvas do 
    copyrect(cliprect, bmp.canvas, 
      rect(fase * breit, 0, fase * breit + breit, bmp.height)); 
  speichern(basis); 
  while fase < bilder - 1 do begin 
    inc(fase); 
    with hlp.Canvas do 
      copyrect(cliprect, bmp.canvas, 
        rect(fase * breit, 0, fase * breit + breit, bmp.height)); 
    if komplett then begin 
      links := 0; 
      oben := 0; 
      sv.assign(hlp); 
    end else begin 
      veraenderungen(basis, hlp); 
      sv.width := rechts - links - 1; 
      sv.height := unten - oben; 
      sv.canvas.copyrect(sv.canvas.cliprect, hlp.canvas, 
        rect(links, oben, rechts, unten)); 
    end; 
    fs.writebuffer(links, sizeof(links)); 
    fs.writebuffer(oben, sizeof(oben)); 
    speichern(sv); 
    basis.canvas.draw(links, oben, sv); 
  end; 
end; 
 
procedure TForm1.optimiere 
  (filename: string; Bildanzahl: word; transparent, komplett: boolean); 
begin 
  bmp.loadfromfile(filename); 
  vorbereitung(filename, Bildanzahl); 
  opti(BildAnzahl, transparent, komplett); 
  fs.free; 
  fs := nil; 
end; 
 
// Beispiel 1
 
procedure TForm1.Button1Click(Sender: TObject); 
var filename: string; 
  Bildzahl: word; 
  transparent, komplett: boolean; 
begin 
  filename := 'c:\strip.bmp'; 
  Bildzahl := 6; 
  transparent := true; 
  komplett := false; 
  optimiere(filename, Bildzahl, transparent, komplett); 
end; 


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

// *.obs laden, decodieren und Strip erstellen 

type 
  TForm1 = class(TForm) 
    Button1: TButton; 
    procedure Button1Click(Sender: TObject); 
    procedure FormDestroy(Sender: TObject); 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private-Deklarationen } 
  public 
    procedure aufteilen; 
    procedure zuweisen(s: TStream; b: TBitmap); 
    procedure build(filename: string); 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.DFM} 
 
type 
  T24 = packed array[0..2] of Byte; 
  rc = record 
    bm: TBitmap; 
    w, h, l, o: word; 
  end; 
 
const 
  flag: byte = $FF; 
 
var 
  fs: TFilestream; 
  bild: array of rc; 
  transparent, komplett: boolean; 
  r, g, b: byte; 
  bmp: TBitmap; 
  breit: integer; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  bmp := TBitmap.create; 
  fs := nil; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
var x: integer; 
begin 
  if fs <> nil then 
    fs.free; 
  for x := 0 to high(bild) do 
    bild[x].bm.free; 
  bild := nil; 
  bmp.free; 
end; 
 
procedure RLED(src, dst: TStream); 
var 
  ccount, n: byte; 
  procedure DC24(Count: byte); 
  var 
    i: byte; 
    Mn: T24; 
  begin 
    src.ReadBuffer(Mn, SizeOf(Mn)); 
    for i := Count downto 1 do 
      dst.WriteBuffer(Mn, SizeOf(Mn)); 
  end; 
begin 
  src.Position := 0; 
  while (src.Size - src.Position >= SizeOf(byte)) do 
  begin 
    src.ReadBuffer(n, SizeOf(n)); 
    if (n = flag) then 
    begin 
      src.ReadBuffer(ccount, SizeOf(ccount)); 
      if (ccount = 0) then dst.WriteBuffer(n, SizeOf(n)) 
      else DC24(ccount); 
    end 
    else dst.WriteBuffer(n, SizeOf(n)); 
  end; 
end; 
 
procedure TForm1.zuweisen(s: TStream; b: TBitmap); 
var x, y, z: integer; 
  p: PByteArray; 
begin 
  for y := 0 to b.height - 1 do begin 
    p := b.scanline[y]; 
    for x := 0 to b.width - 1 do 
      for z := 0 to 2 do 
        s.readbuffer(p[x * 3 + z], 1); 
  end; 
end; 
 
procedure TForm1.aufteilen; 
var w: word; 
  x, i: integer; 
  src, dst: TMemoryStream; 
begin 
  src := TMemoryStream.create; 
  dst := TMemoryStream.create; 
  fs.readbuffer(breit, sizeof(breit)); 
  fs.readbuffer(w, sizeof(w)); 
  setlength(bild, w); 
  for x := 0 to high(bild) do begin 
    bild[x].bm := TBitmap.create; 
    bild[x].bm.pixelformat := pf24bit; 
  end; 
  bild[0].o := 0; 
  bild[0].l := 0; 
  fs.readbuffer(transparent, sizeof(transparent)); 
  fs.readbuffer(komplett, sizeof(komplett)); 
  fs.readbuffer(r, 1); 
  fs.readbuffer(g, 1); 
  fs.readbuffer(b, 1); 
  fs.readbuffer(bild[0].w, sizeof(w)); 
  bild[0].bm.width := bild[0].w; 
  fs.readbuffer(bild[0].h, sizeof(w)); 
  bild[0].bm.height := bild[0].h; 
  fs.readbuffer(x, sizeof(x)); 
  src.copyfrom(fs, x); 
  RLED(src, dst); 
  dst.position := 0; 
  zuweisen(dst, bild[0].bm); 
  for x := 1 to high(bild) do begin 
    src.size := 0; 
    dst.size := 0; 
    fs.readbuffer(bild[x].l, sizeof(w)); 
    fs.readbuffer(bild[x].o, sizeof(w)); 
    fs.readbuffer(bild[x].w, sizeof(w)); 
    fs.readbuffer(bild[x].h, sizeof(w)); 
    fs.readbuffer(i, sizeof(i)); 
    src.copyfrom(fs, i); 
    RLED(src, dst); 
    dst.position := 0; 
    bild[x].bm.width := bild[x].w; 
    bild[x].bm.height := bild[x].h; 
    zuweisen(dst, bild[x].bm); 
    bild[x].bm.transparentcolor := RGB(r, g, b); 
    bild[x].bm.transparent := not komplett; 
  end; 
  src.free; 
  dst.free; 
end; 
 
procedure TForm1.build(filename: string); 
var x, y: integer; 
begin 
  fs := TFilestream.create(filename, fmOpenRead or fmShareExclusive); 
  aufteilen; 
  fs.free; 
  fs := nil; 
  bmp.height := bild[0].h; 
  bmp.width := bild[0].w * length(bild); 
  if bmp.width <> breit 
    then raise exception.create('Abmaße oder Bilderzahl fehlerhaft'); 
  for x := 0 to high(bild) do 
    bmp.canvas.draw(x * bild[0].w, 0, bild[0].bm); 
  for x := high(bild) downto 1 do 
    for y := 1 to x do 
      bmp.canvas.draw(x * bild[0].w + bild[y].l, bild[y].o, bild[y].bm); 
  bmp.transparentcolor := RGB(r, g, b); 
  bmp.transparent := transparent; 
end; 
 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  build('c:\Strip.obs'); 
  // und zur Kontrolle: 
  Canvas.draw(10, 10, bmp); 
end;