Delphi控件源码

开发平台：
Delphi

MMBmpLst.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49(0)351-8037944               =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/index.html               =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 04.01.99 - 16:58:05 $                                        =}
{========================================================================}
unit MMBmpLst;
{$I COMPILER.INC}
interface
uses
    Windows,
    Messages,
    SysUtils,
    Classes,
    Controls,
    Graphics,
    Buttons,
    Forms,
    MMObj,
    MMUtils,
    MMString,
    MMObsrv;
const
    CM_TRANSCOLORCHANGED = CM_BASE + 250;
type
    {$IFNDEF DELPHI3}
    TTransparentMode  = (tmAuto, tmFixed);
    TBitmapHandleType = (bmDIB, bmDDB);
    {$ENDIF}
    TEncodeEvent  = procedure(Sender: TObject; Buffer: PChar; Length: DWORD) of object;
    TLoadedEvent  = procedure(Sender: TObject; Bmp: TBitmap) of object;
    {-- TMMBitmapList ---------------------------------------------------------}
    TMMBitmapList = class(TMMNonVisualComponent)
    private
       FList       : TList;
       FUpdateCount: Integer;
       FObservable : TMMObservable;
       FCompressed : Boolean;
       FHandleType : TBitmapHandleType;
       FOnChange   : TNotifyEvent;
       FOnChanging : TNotifyEvent;
       FOnEncode   : TEncodeEvent;
       FOnDecode   : TEncodeEvent;
       FOnLoaded   : TLoadedEvent;
       function  GetCount: integer;
       function  GetEmpty: Boolean;
       procedure Put(Index: integer; Item: TBitmap);virtual;
       function  Get(Index: integer): TBitmap; virtual;
       procedure BMPChanged(Sender: TObject);
       procedure SaveCompressedStream(Src, Target: TStream; Size: Longint);
       procedure LoadCompressedStream(Src, Target: TStream);
    protected
       procedure Changed; virtual;
       procedure Changing; virtual;
       procedure ReadData(Stream: TStream); virtual;
       procedure WriteData(Stream: TStream); virtual;
       procedure DefineProperties(Filer: TFiler); override;
       procedure SetUpdateState(Updating: Boolean); virtual;
       procedure LoadFromStreamEx(Stream: TStream; Replace: Boolean);
    public
       constructor Create(aOwner: TComponent); override;
       destructor Destroy; override;
       procedure AddObserver(O: TMMObserver);
       procedure RemoveObserver(O: TMMObserver);
       procedure BeginUpdate;
       procedure EndUpdate;
       procedure Assign(Source: TPersistent); override;
       procedure LoadFromStream(Stream: TStream);
       procedure ReplaceFromStream(Stream: TStream);
       procedure SaveToStream(Stream: TStream);
       procedure LoadFromFile(const FName: TFileName);
       procedure ReplaceFromFile(const FName: TFileName);
       procedure SaveToFile(const FName: TFileName);
       procedure AddListFromFile(const FName: TFileName);
       function  First: TBitmap;
       function  Last: TBitmap;
       procedure Clear;
       procedure AddFromFile(const FName: TFileName);
       procedure ExtractToFile(index: integer; const FName: TFileName);
       function  Add(Item: TBitmap): integer;
       procedure AddList(List: TMMBitmapList);
       procedure Insert(Index: integer; Item: TBitmap);
       procedure Move(OldIndex, NewIndex: integer);
       procedure Exchange(Index1, Index2: integer);
       procedure Delete(index: integer);
       function  Remove(Item: TBitmap): integer;
       function IndexOf(Item: TBitmap): integer;
       property Count: integer read GetCount;
       property Empty: Boolean read GetEmpty;
       property Items[Index: integer]: TBitmap read Get write Put; default;
    published
       property OnChange: TNotifyEvent read FOnChange write FOnChange;
       property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
       property OnDecode: TEncodeEvent read FOnDecode write FOnDecode;
       property OnEncode: TEncodeEvent read FOnEncode write FOnEncode;
       property OnBmpLoaded: TLoadedEvent read FOnLoaded write FonLoaded;
       property Compressed: Boolean read FCompressed write FCompressed default False;
       property HandleType: TBitmapHandleType read FHandleType write FHandleType default bmDDB;
    end;
    {-- TMMCustomBitmapListControl --------------------------------------------}
    TMMCustomBitmapListControl = class(TMMGraphicControl)
    private
       FTag2           : Longint;
       FBitmapIndex    : integer;
       FBitmaps        : TMMBitmapList;
       FObserver       : TMMObserver;
       FTransColor     : TColor;
       FTransMode      : TTransparentMode;
       FBitmapBackIndex: integer;
       procedure SetBitmaps(aValue: TMMBitmapList);
       procedure BitmapsNotify(Sender, Data: TObject);
       procedure SetBitmapIndex(aValue: integer);
       procedure SetBitmapBackIndex(aValue: integer);
       function  GetBitmap: TBitmap;
       procedure SetTransparentColor(aValue: TColor);
       procedure SetTransparentMode(aValue: TTransparentMode);
       function  TransparentColorStored: Boolean;
       procedure CMTransColorChanged(var Message: TMessage); message CM_TRANSCOLORCHANGED;
    protected
       function  FindTransparentColor: TColor; virtual;
       function  GetTransparentColor: TColor; virtual;
       procedure Notification(AComponent: TComponent; Operation: TOperation); override;
       function  GetPalette: HPALETTE; override;
       procedure BitmapChanged; virtual;
    public
       constructor Create(AOwner: TComponent); override;
       destructor  Destroy; override;
       function BitmapValid: Boolean;
       property Bitmap: TBitmap read GetBitmap;
       property BitmapList: TMMBitmapList read FBitmaps write SetBitmaps;
       property BitmapIndex: Integer read FBitmapIndex write SetBitmapIndex default -1;
       property BitmapBackIndex: Integer read FBitmapBackIndex write SetBitmapBackIndex default -1;
       property TransparentColor: TColor read GetTransparentColor write SetTransparentColor stored TransparentColorStored;
       property TransparentMode: TTransparentMode read FTransMode write SetTransparentMode default tmAuto;
    published
       property Tag2: Longint read FTag2 write FTag2 default 0;
    end;
    TMMGlyphOrientation = (goHorizontal,goVertical);
    TMMPaintImage       = procedure(Sender: TObject; Canvas: TCanvas; DstRect, SrcRect: TRect) of object;
    {-- TMMBitmapListImage ----------------------------------------------------}
    TMMBitmapListImage  = class(TMMCustomBitmapListControl)
    private
       FAutoSize   : Boolean;
       FNumGlyphs  : integer;
       FGlyphIndex : integer;
       FGlyphOrient: TMMGlyphOrientation;
       FHorizMargin: integer;
       FVertMargin : integer;
       FOnPaint    : TMMPaintImage;
       procedure SetAutoSize(aValue: Boolean);
       procedure SetNumGlyphs(aValue: integer);
       procedure SetGlyphIndex(aValue: integer);
       procedure SetGlyphOrient(aValue: TMMGlyphOrientation);
       procedure PaintBitmap;
    protected
       function  GetSrcRect(index: integer): TRect; virtual;
       procedure FastDraw; virtual;
       procedure DoAutoSize; virtual;
       procedure Paint; override;
       procedure BitmapChanged; override;
    public
       constructor Create(AOwner: TComponent); override;
    published
       property OnClick;
       property OnDblClick;
       property OnDragDrop;
       property OnDragOver;
       property OnEndDrag;
       property OnStartDrag;
       property OnMouseDown;
       property OnMouseMove;
       property OnMouseUp;
       property OnPaint: TMMPaintImage read FOnPaint write FOnPaint;
       property Align;
       property Enabled;
       property PopupMenu;
       property ParentShowHint;
       property ShowHint;
       property Visible;
       property DragCursor;
       property DragMode;
       property BitmapList;
       property BitmapIndex;
       property BitmapBackIndex;
       property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
       property NumGlyphs: integer read FNumGlyphs write SetNumGlyphs;
       property GlyphOrientation: TMMGlyphOrientation read FGlyphOrient write SetGlyphOrient default goHorizontal;
       property GlyphIndex: integer read FGlyphIndex write SetGlyphIndex default 0;
    end;
implementation
const
     STREAMKENNUNG      : Longint = $4C4D424D; { 'MBML' }
     STREAMKENNUNG_COMP : Longint = $434D424D; { 'MBMC' }
{== TMMBitmapList =============================================================}
constructor TMMBitmapList.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
   FList        := TList.Create;
   FOnChange    := nil;
   FOnChanging  := nil;
   FUpdateCount := 0;
   FObservable  := TMMObservable.Create;
   FCompressed  := False;
   FHandleType  := bmDDB;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMBitmapList -------------------------------------------------------------}
destructor TMMBitmapList.Destroy;
begin
   FOnChange := nil;
   FOnChanging := nil;
   Clear;
   Flist.Free;
   FObservable.Free;
   FObservable:= nil;
   inherited Destroy;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.AddObserver(O: TMMObserver);
begin
   FObservable.AddObserver(O);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.RemoveObserver(O: TMMObserver);
begin
   if (FObservable <> nil) then
       FObservable.RemoveObserver(O);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.BeginUpdate;
begin
  if FUpdateCount = 0 then SetUpdateState(True);
  inc(FUpdateCount);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.EndUpdate;
begin
   dec(FUpdateCount);
   if FUpdateCount = 0 then SetUpdateState(False);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.SetUpdateState(Updating: Boolean);
begin
  if Updating then Changing else Changed;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Changed;
begin
   if (FUpdateCount = 0) then
   begin
      inc(FUpdateCount);
      try
         FObservable.NotifyObservers(Self);
         if Assigned(FOnChange) then FOnChange(Self);
      finally
         dec(FUpdateCount);
      end;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Changing;
begin
   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.BMPChanged(Sender: TObject);
begin
   Changed;
end;
{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.GetCount: integer;
begin
   Result := FList.Count;
end;
{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.GetEmpty: Boolean;
begin
   Result := (Flist.Count = 0)
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Assign(Source: TPersistent);
begin
   if (Source = nil) then
   begin
      Clear;
   end
   else if (Source is TMMBitmapList) then
   begin
      BeginUpdate;
      try
         {$IFDEF WIN32}
         {$IFDEF TRIAL}
         {$DEFINE _HACK1}
         {$I MMHACK.INC}
         {$ENDIF}
         {$ENDIF}
         Clear;
         AddList(TMMBitmapList(Source));
         Compressed := TMMBitmapList(Source).Compressed;
      finally
         EndUpdate;
      end;
   end
   else inherited Assign(Source)
end;
{-- TMMBitmapList -------------------------------------------------------------}
function TMMBitmapList.Add(Item: TBitmap): integer;
begin
   Result := Count;
   Insert(Result, Item);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.AddList(List: TMMBitmapList);
var
   i: integer;
begin
   BeginUpdate;
   try
      for i := 0 to List.Count-1 do Add(List[i]);
   finally
      EndUpdate;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Insert(Index: integer; Item: TBitmap);
var
   BMP: TBitmap;
begin
   Changing;
   BMP := TBitmap.Create;
   BMP.Assign(Item);
   BMP.OnChange := BMPChanged;
   FList.Insert(Index,BMP);
   Changed;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.AddFromFile(const FName: TFileName);
var
   BMP: TBitmap;
begin
   BMP := TBitmap.Create;
   try
      BMP.LoadFromFile(FName);
      Add(Bmp);
   finally
      BMP.Free;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.ExtractToFile(index: integer; const FName: TFileName);
begin
   TBitmap(Flist[index]).SaveToFile(FName);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.Clear;
var
   i: integer;
begin
   BeginUpdate;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK2}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
   try
      for i := Count-1 downto 0 do Delete(i);
   finally
      EndUpdate;
   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);
            Size := Stream.Position - (OldPos + SizeOf(Size));
            Pos := Stream.Position;
            Stream.Position := OldPos;
            Stream.Write(Size, SizeOf(Size));
            Stream.Position := Pos;
         end;
      end;
   finally
      EndUpdate;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.ReadData(Stream: TStream);
begin
   LoadFromStream(Stream);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.WriteData(Stream: TStream);
begin
   SaveToStream(Stream);
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.LoadFromFile(const FName: TFileName);
var
  Stream: TStream;
begin
   Stream := TFileStream.Create(FName, fmOpenRead);
   try
      LoadFromStream(Stream);
   finally
      Stream.Free;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.ReplaceFromFile(const FName: TFileName);
var
  Stream: TStream;
begin
   Stream := TFileStream.Create(FName, fmOpenRead);
   try
      ReplaceFromStream(Stream);
   finally
      Stream.Free;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.SaveToFile(const FName: TFileName);
var
  Stream: TStream;
begin
   Stream := TFileStream.Create(FName, fmCreate);
   try
      SaveToStream(Stream);
   finally
      Stream.Free;
   end;
end;
{-- TMMBitmapList -------------------------------------------------------------}
procedure TMMBitmapList.AddListFromFile(const FName: TFileName);
var
   BML: TMMBitmapList;
begin
   BML := TMMBitmapList.Create(nil);
   try
      BML.LoadFromFile(FName);
      AddList(BML);
   finally
      BML.Free;
   end;
end;
{== TMMCustomBitmapListControl ================================================}
constructor TMMCustomBitmapListControl.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   ControlStyle      := ControlStyle - [csOpaque];
   FBitmapIndex      := -1;
   FBitmapBackIndex  := -1;
   FBitmaps          := nil;
   FObserver         := TMMObserver.Create;
   FObserver.OnNotify:= BitmapsNotify;
   FTag2             := 0;
   FTransColor       := clDefault;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
destructor TMMCustomBitmapListControl.Destroy;
begin
   BitmapList := nil;
   FObserver.Free;
   inherited Destroy;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.Notification(AComponent: TComponent; Operation: TOperation);
begin
   inherited Notification(AComponent, Operation);
   if (Operation = opRemove) then
   begin
      if (aComponent = BitmapList) then BitmapList := nil;
   end;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.BitmapChanged;
begin
   if (csDesigning in ComponentState) then
       Refresh
   else if (Parent <> nil) and (Parent.HandleAllocated) then
       Paint;
   Refresh;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.BitmapsNotify(Sender, Data: TObject);
begin
   BitmapChanged;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetBitmaps(aValue: TMMBitmapList);
begin
  { bug fix for AX Controls }
  if integer(aValue) = integer(Self) then exit;
  if (FBitmaps <> nil) then FBitmaps.RemoveObserver(FObserver);
  FBitmaps := aValue;
  if (FBitmaps <> nil) then
  begin
     FBitmaps.AddObserver(FObserver);
     {$IFNDEF BUILD_ACTIVEX}
     if aValue <> nil then aValue.FreeNotification(Self);
     {$ENDIF}
  end;
  BitmapChanged;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetBitmapIndex(aValue: integer);
begin
   if (FBitmapIndex <> aValue) then
   begin
      FBitmapIndex := Max(aValue,-1);
      BitmapChanged;
   end;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListcontrol.SetBitmapBackIndex(aValue: integer);
begin
   if (FBitmapBackIndex <> aValue) then
   begin
      FBitmapBackIndex := Max(aValue,-1);
      Invalidate;
   end;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.BitmapValid: Boolean;
begin
   Result := (FBitmaps <> nil) and (FBitmapIndex >= 0) and (FBitmapIndex <  FBitmaps.Count);
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.GetBitmap: TBitmap;
begin
   if BitmapValid then
      Result := FBitmaps[BitmapIndex]
   else
      Result := nil;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.FindTransparentColor: TColor;
begin
   Result := clDefault;
   if BitmapValid then
      Result := MMUtils.GetTransparentColor(Bitmap.Handle);
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.GetTransparentColor: TColor;
begin
   if (FTransColor = clDefault) then
      Result := FindTransparentColor
   else
      Result := ColorToRGB(FTransColor);
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetTransparentColor(aValue: TColor);
begin
   if (aValue <> FTransColor) then
   begin
      if (aValue = clDefault) then
          FTransMode := tmAuto
      else
          FTransMode := tmFixed;
      FTransColor := aValue;
      Perform(CM_TRANSCOLORCHANGED, 0, 0);
  end;
  {$IFDEF WIN32}
  {$IFDEF TRIAL}
  {$DEFINE _HACK2}
  {$I MMHACK.INC}
  {$ENDIF}
  {$ENDIF}
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.SetTransparentMode(aValue: TTransparentMode);
begin
   if (aValue <> FTransMode) then
   begin
      if (aValue = tmAuto) then
          SetTransparentColor(clDefault)
      else
          SetTransparentColor(GetTransparentColor);
   end;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.TransparentColorStored: Boolean;
begin
   Result := FTransMode = tmFixed;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
procedure TMMCustomBitmapListControl.CMTransColorChanged(var message: TMessage);
begin
   Invalidate;
end;
{-- TMMCustomBitmapListControl ------------------------------------------------}
function TMMCustomBitmapListControl.GetPalette: HPALETTE;
begin
   if BitmapValid then
      Result := Bitmap.Palette
   else
      Result := 0;
end;
{== TMMBitmapListImage ========================================================}
constructor TMMBitmapListImage.Create(AOwner: TComponent);
begin
   inherited Create(AOwner);
   FNumGlyphs   := 1;
   FAutoSize    := False;
   FGlyphOrient := goHorizontal;
   FGlyphIndex  := 0;
   FHorizMargin := 0;
   FVertMargin  := 0;
   Width        := 80;
   Height       := 80;
   {$IFDEF WIN32}
   {$IFDEF TRIAL}
   {$DEFINE _HACK1}
   {$I MMHACK.INC}
   {$ENDIF}
   {$ENDIF}
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.BitmapChanged;
begin
   DoAutoSize;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.DoAutoSize;
var
   W,H: integer;
begin
   if (csLoading in ComponentState) or
      (csReading in ComponentState) or
      (csDestroying in ComponentState) then exit;
   if BitmapValid and FAutosize then
   begin
      if (FGlyphOrient = goHorizontal) then
      begin
         W := Bitmap.Width div FNumGlyphs;
         if (W > 0) and (Bitmap.Height > 0) then
             SetBounds(Left, Top, W, Bitmap.Height);
      end
      else
      begin
         H := Bitmap.Height div FNumGlyphs;
         if (H > 0) and (Bitmap.Width > 0) then
             SetBounds(Left, Top, Bitmap.Width, H);
      end;
   end;
   Invalidate;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetNumGlyphs(aValue: integer);
begin
   if (FNumGlyphs <> aValue) then
   begin
      FNumGlyphs := Max(aValue,1);
      DoAutosize;
   end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetGlyphOrient(aValue: TMMGlyphOrientation);
begin
   if (FGlyphOrient <> aValue) then
   begin
      FGlyphOrient := aValue;
      DoAutoSize;
   end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetAutoSize(aValue: Boolean);
begin
   if (aValue <> FAutoSize) then
   begin
      FAutoSize := aValue;
      DoAutoSize;
   end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.SetGlyphIndex(aValue: integer);
begin
   if (aValue <> FGlyphIndex) then
   begin
      FGlyphIndex := aValue;
      if (csDesigning in ComponentState) then
         Refresh
      else
         FastDraw;
   end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
function TMMBitmapListImage.GetSrcRect(index: integer): TRect;
begin
   index := Min(index,FNumGlyphs-1);
   if (FGlyphOrient = goHorizontal) then
   begin
      Result.Left := index * (Bitmap.Width div FNumGlyphs);
      Result.Top := 0;
      Result.Right := (index+1) * (Bitmap.Width div FNumGlyphs);
      Result.Bottom := Bitmap.Height;
   end
   else
   begin
      Result.Left := 0;
      Result.Top := index * (Bitmap.Height div FNumGlyphs);
      Result.Right := Bitmap.Width;
      Result.Bottom := Min((index+1) * (Bitmap.Height div FNumGlyphs),Bitmap.Height);
   end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.FastDraw;
var
  DC: HDC;
  Control: TWinControl;
begin
   Control := Parent;
   if Visible and (Control <> nil) and Control.HandleAllocated then
   begin
      DC := GetDC(Control.Handle);
      try
        {$IFDEF DELPHI3}
        Canvas.Lock;
        {$ENDIF}
        if RectVisible(DC, Rect(Left, Top, Left + Width, Top + Height)) then
        begin
           MoveWindowOrg(DC, Left, Top);
           IntersectClipRect(DC, 0, 0, Width, Height);
           Canvas.Handle := DC;
           PaintBitmap;
        end;
      finally
        Canvas.Handle := 0;
        ReleaseDC(Control.Handle, DC);
        {$IFDEF DELPHI3}
        Canvas.Unlock;
        {$ENDIF}
      end;
  end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.PaintBitmap;
begin
   if (Visible or (csDesigning in ComponentState)) and BitmapValid then
   begin
      {$IFDEF DELPHI3}
      Bitmap.Canvas.Lock;
      {$ENDIF}
      try
         if not (csDesigning in ComponentState) and assigned(FOnPaint) then
            FOnPaint(Self,Canvas,Rect(0,0,Width,Height),GetSrcRect(FGlyphIndex))
         else
            Canvas.CopyRect(Rect(0,0,Width,Height),
                            Bitmap.Canvas,
                            GetSrcRect(FGlyphIndex));
      finally
         {$IFDEF DELPHI3}
         Bitmap.Canvas.UnLock;
         {$ENDIF}
      end;
   end
   else if csDesigning in ComponentState then
   begin
      Canvas.Brush.Style := bsClear;
      Canvas.Pen.Color   := clBlack;
      Canvas.Pen.Style   := psDot;
      Canvas.Rectangle(0,0,Width,Height);
   end;
end;
{-- TMMBitmapListImage --------------------------------------------------------}
procedure TMMBitmapListImage.Paint;
begin
   PaintBitmap;
end;
end.

						