mmbmplst.pas

一套及时通讯的原码

   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.Remove(Item: TBitmap): integer;
begin
   Result := IndexOf(Item);
   if Result <> -1 then Delete(Result);
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Delete(Index: integer);
var
   BMP: TBitmap;
begin
   Changing;
   BMP := Flist[index];
   FList.Delete(index);
   BMP.Free;
   Changed;
end;

{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.First: TBitmap;
begin
   Result := FList[0];
end;

{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.Last: TBitmap;
begin
   Result := FList[Count-1];
end;

{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.Get(Index: integer): TBitmap;
begin
   Result := FList[Index];

   {$IFDEF DELPHI3}
   { prevent change events ! }
   inc(FUpdateCount);
   try
      { make all Bitmaps compatible with previous versions of Delphi }
      if (HandleType = bmDDB) then
          Result.HandleType := bmDDB
      else
          Result.HandleType := bmDIB;

   finally
      dec(FUpdateCount);
   end;
   {$ENDIF}
end;

{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.IndexOf(Item: TBitmap): integer;
begin
   Result := FList.IndexOf(Item);
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Exchange(Index1, Index2: integer);
begin
   Changing;
   FList.Exchange(Index1,Index2);
   Changed;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Move(OldIndex, NewIndex: integer);
begin
   Changing;
   FList.Move(OldIndex,NewIndex);
   Changed;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Put(Index: integer; Item: TBitmap);
begin
   Changing;
   FList[Index] := Item;
   Changed;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.DefineProperties(Filer: TFiler);
begin
   inherited DefineProperties(Filer);
   Filer.DefineBinaryProperty('ListItems', ReadData, WriteData, Count > 0);
end;

{------------------------------------------------------------------------------}
{ compression routines, basing on routines from SWAG                           }
{------------------------------------------------------------------------------}
const
  MaxBufferSize  =32767;
  MaxBufferIndex = MaxBufferSize+14;

const
  FLAG_Copied    = $80;
  FLAG_Compress  = $40;

type
  TBufferSize    = 0..MaxBufferSize;
  TBufferIndex   = 0..MaxBufferIndex;

  PBuffer        = ^TABuffer;
  TABuffer       = array[TBufferIndex] of Byte;

  PLZTable       = ^LZTable;
  LZTable        = array[0..4096-1] of SmallInt;


{$R-}
{------------------------------------------------------------------------------}
function LZRWCompress(Source, Dest: PBuffer; SourceSize: TBufferSize): TBufferSize;
var
  Hash: PLZTable;
  Key,Bit,Command,Size: integer;
  X,Y,Z,Pos: integer;

  function FindMatch(Source: PBuffer; X: TBufferIndex; SourceSize: TBufferSize;
                     Hash: PLZTable; var iSize, Pos: integer): Boolean;
  var
     TmpHash: SmallInt;
     HashValue: Word;

  begin
     HashValue:=(40543*((((Source^[X] shl 4) xor Source^[X+1]) shl 4) xor Source^[X+2]) shr 4) and $0FFF;
     Result := False;
     TmpHash:= Hash^[HashValue];
     if (TmpHash <> -1) and (X - TmpHash < 4096) then
     begin
        Pos  := TmpHash;
        iSize:= 0;
        while((iSize < 18) and (Source^[X+iSize] = Source^[Pos+iSize]) and (X+iSize<SourceSize)) do Inc(iSize);
        Result := (iSize >= 3)
     end;
     Hash^[HashValue] := X
  end;

begin
   try
      Getmem(Hash,Sizeof(LZTable));
   except
      raise EInvalidPointer.Create('LZRW Error!');
      exit;
   end;

   FillChar(Hash^, SizeOf(LZTable), $FF);
   Dest^[0] := FLAG_Compress;
   X := 0;
   Y := 3;
   Z := 1;
   Bit := 0;
   Command := 0;
   while (X < SourceSize) and (Y <= SourceSize) do
   begin
      if (Bit > 15) then
      begin
         Dest^[Z] := Hi(Command);
         Dest^[Z+1] := Lo(Command);
         Z:=Y;
         Bit := 0;
         Inc(Y,2)
      end;
      Size:=1;
      while ((Source^[X] = Source^[X+Size]) and (Size<$FFF) and (X+Size<SourceSize)) do Inc(Size);

      if (Size >= 16) then
      begin
         Dest^[Y]:= 0;
         Dest^[Y+1]:= Hi(Size-16);
         Dest^[Y+2]:= Lo(Size-16);
         Dest^[Y+3]:= Source^[X];
         Inc(Y,4);
         Inc(X,Size);
         Command:=(Command shl 1) + 1;
      end
      else if (FindMatch(Source,X,SourceSize,Hash,Size,Pos)) then
      begin
         Key := ((X-Pos) shl 4) + (Size-3);
         Dest^[Y] := Hi(Key);
         Dest^[Y+1] := Lo(Key);
         Inc(Y,2);
         Inc(X,Size);
         Command := (Command shl 1) + 1
      end
      else
      begin
         Dest^[Y] := Source^[X];
         Inc(Y);
         Inc(X);
         Command := Command shl 1
      end;
      Inc(Bit);
   end;

   Command := Command shl (16-Bit);
   Dest^[Z] := HI(Command);
   Dest^[Z+1] := LO(Command);
   if (Y > SourceSize) then
   begin
      Move(Source^[0],Dest^[1],SourceSize);
      Dest^[0] := FLAG_Copied;
      Y := Succ(SourceSize)
   end;
   Result := Y;

   if (Hash <> nil) then FreeMem(Hash, Sizeof(LZTable));
end;

{------------------------------------------------------------------------------}
function LZRWDecompress(Source,Dest: PBuffer; Size: TBufferSize): TBufferSize;
var
   X,Y,SaveY,Pos: TBufferIndex;
   BSize,K,Command: Word;
   Bit: Byte;
begin
   SaveY := 0;
   if (Source^[0] = FLAG_Copied) then
   begin
      for y := 1 to Pred(Size) do
      begin
         Dest^[Pred(Y)] := Source^[Y];
         SaveY := Y;
      end;
      Y := SaveY;
   end
   else
   begin
      y := 0;
      X := 3;
      Command := (Source^[1] shl 8) + Source^[2];
      Bit := 16;
      while (X < Size) do
      begin
         if (Bit = 0) then
         begin
            Command := (Source^[X] shl 8) + Source^[X+1];
            Bit := 16;
            Inc(X,2)
         end;
         if ((Command and $8000) = 0) then
         begin
            Dest^[Y] := Source^[X];
            inc(X); inc(Y)
         end
         else
         begin
            Pos:=((Source^[X] shl 4)+(Source^[X+1] shr 4));
            if (Pos = 0) then
            begin
               BSize := (Source^[X+1] shl 8) + Source^[X+2] + 15;
               for k := 0 to BSize do
                   Dest^[Y+K] := Source^[X+3];
               Inc(X,4);
               Inc(Y,BSize+1)
            end
            else
            begin
               BSize := (Source^[X+1] and $0F)+2;
               for k := 0 to BSize do
                   Dest^[Y+K] := Dest^[Y-Pos+K];
               Inc(X,2);
               Inc(Y,BSize+1)
            end;
         end;
         Command := Command shl 1;
         Dec(Bit);
      end;
   end;
   Result := Y
end;

{------------------------------------------------------------------------------}
procedure TMMBitmapList.SaveCompressedStream(Src, Target: TStream; Size: Longint);
var
   bi, bo: PBuffer;
   OldPos, NewPos, c, r,s: Longint;
begin
   c := 0;
   OldPos := Target.Position;
   Target.Position := Oldpos+sizeOf(c);
   bi := nil;
   bo := nil;
   try
      GetMem(bi, MaxBufferIndex);
      GetMem(bo, MaxBufferIndex);
      while (Size > 0) do
      begin
         r := Src.Read(bi^, MaxBufferIndex);
         s := LZRWCompress(bi, bo, r);
         Target.Write(s, SizeOf(s));
         if assigned(FOnEncode) then
            FOnEncode(Self,PChar(bo),s);
         Target.WriteBuffer(bo^, s);
         inc(c, s+SizeOf(s));
         dec(Size, r);
      end;
      NewPos := Target.Position;
      Target.Position := OldPos;
      Target.Write(c, SizeOf(c));
      Target.Position := NewPos;
   finally
      FreeMem(bi, MaxBufferIndex);
      FreeMem(bo, MaxBufferIndex);
   end;
end;

{------------------------------------------------------------------------------}
procedure TMMBitmapList.LoadCompressedStream(Src, Target: TStream);
var
   c, s, SrcSize: LongInt;
   bi, bo: PBuffer;

begin
   bi := nil;
   bo := nil;
   try
      GetMem(bi, MaxBufferIndex);
      GetMem(bo, MaxBufferIndex);
      Src.Read(SrcSize, SizeOf(SrcSize));
      while (SrcSize > 0) do
      begin
         Src.Read(c, SizeOf(c));
         Src.ReadBuffer(bi^, c);
         if assigned(FOnDecode) then FOnDecode(Self,PChar(bi),c);
         s := LZRWDecompress(bi, bo, c);
         Target.WriteBuffer(bo^, s);
         dec(SrcSize, c+sizeOf(c));
      end;
   finally
      FreeMem(bi, MaxBufferIndex);
      FreeMem(bo, MaxBufferIndex);
   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.LoadFromStreamEx(Stream: TStream; Replace: Boolean);
var
   i: integer;
   Kennung,BmpCount,Size: Longint;
   MemStream: TMemoryStream;
   Bmp: TBitmap;

begin
   BeginUpdate;
   try
      {$IFDEF WIN32}
      {$IFDEF TRIAL}
      {$DEFINE _HACK3}
      {$I MMHACK.INC}
      {$ENDIF}
      {$ENDIF}

      { load stream items }
      if not Replace then Clear;

      Stream.ReadBuffer(Kennung,sizeOf(STREAMKENNUNG));
      if (Kennung <> STREAMKENNUNG) and (Kennung <> STREAMKENNUNG_COMP) then
          raise EStreamError.Create('Invalid BitmapList stream');

      Stream.ReadBuffer(BmpCount, SizeOf(BmpCount));

      MemStream := TMemoryStream.Create;
      try
         Bmp := TBitmap.Create;
         try
            for i := 0 to BmpCount-1 do
            begin
               MemStream.Position := 0;

               if (Kennung = STREAMKENNUNG_COMP) then
               begin
                  LoadCompressedStream(Stream, MemStream);
                  MemStream.Position := 0;
               end
               else
               begin
                  Stream.ReadBuffer(Size, SizeOf(Size));
                  MemStream.SetSize(Size);
                  MemStream.Position := 0;
                  Stream.ReadBuffer(MemStream.Memory^, Size);
               end;
               if not Replace or (i >= Count) then
               begin
                  Bmp.LoadFromStream(MemStream);
                  Add(Bmp);
               end
               else
               begin
                  Items[i].LoadFromStream(MemStream);
               end;
               if assigned(FonLoaded) then
                  FOnLoaded(Self,Items[i]);
            end;

         finally
            Bmp.Free;
         end;

      finally
         MemStream.Free;
      end;

   finally
      EndUpdate;
   end;
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.LoadFromStream(Stream: TStream);
begin
   LoadFromStreamEx(Stream,False);
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.ReplaceFromStream(Stream: TStream);
begin
   LoadFromStreamEx(Stream,True);
end;

{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.SaveToStream(Stream: TStream);
var
   i: integer;
   Size,OldPos,Pos: Longint;
   MemStream: TMemoryStream;
begin
   BeginUpdate;
   try
      { Write list to Stream }
      if FCompressed then
         Stream.WriteBuffer(STREAMKENNUNG_COMP,SizeOf(STREAMKENNUNG_COMP))
      else
         Stream.WriteBuffer(STREAMKENNUNG,SizeOf(STREAMKENNUNG));

      Size := Count;
      Stream.WriteBuffer(Size,SizeOf(Size));
      for i := 0 to Count-1 do
      begin
         if Compressed then
         begin
            // TODO: optimieren ???
            MemStream := TMemoryStream.Create;
            try
               Items[i].SaveToStream(MemStream);
               MemStream.Position := 0;
               SaveCompressedStream(MemStream, Stream, MemStream.Size);
            finally
               MemStream.Free;
            end;
         end
         else
         begin
            OldPos := Stream.Position;
            Stream.WriteBuffer(Size,SizeOf(Size));
            //Items[i].PixelFormat := pf16Bit;// wieder weg...
            Items[i].SaveToStream(Stream);