mmbmplst.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [phone]               =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  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;