cdibimagelist.pas

Delphi控件

unit cDIBImageList;

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: cDIBImageList.PAS, released August 28, 2000.

The Initial Developer of the Original Code is Peter Morris ([e-mail]),
Portions created by Peter Morris are Copyright (C) 2000 Peter Morris.
All Rights Reserved.

Purpose of file:
This list may hold many images + their alpha masks.  All components should make use
of a DIBImageList rather than having the graphic data stored within the component.
(To save on application size)

Contributor(s):
None as yet


Last Modified: Oct 15, 2003

You may retrieve the latest version of this file at http://www.droopyeyes.com


Known Issues:
To be updated !
-----------------------------------------------------------------------------}
//Modifications
(*
Date:   April 6, 2001
By:     Peter Morris
Change: Added a fault property to TImageList;

Date:   April 6, 2001
By:     Peter Morris
Change: Added an ImageByName function

Date:   August 12, 2002
By:     Hans-J黵gen Schnorrenberg
Change: ListChanged modified in order to provide the ImageIndex of an image in deletion
        FOwner and SetOwner of TImages replaced by inherited Owner

Date:   August 20, 2002
By:     Hans-J黵gen Schnorrenberg
Change: Added ImageMoved to TDIBImageItem triggered by SetIndex;
        Added ImageMoved method to TDIBImages, TDIBImageList;

Date:   November 24, 2002
By:     Peter Morris
Change: Added TCustomDIBImageList.GetItemClass.  This will allow developers to
        create their own descendant of TCustomDIBImageList and specify their own
        descendant class of TDIBImagesItem to be used to hold images.

Date:   March 23, 2003
By:     Peter Morris
Change: Added the ability to store images outside of the exe's resource.
        You can now specify
        irInternal - Inside EXE
        irLoadOnStart - Load from file on app start
        irLoadOnDemand - Load from file when first used

Date:   October 15, 2003
By:     Peter Morris
Change: Added ItemByName and FindByName to DIBImageList
*)

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, cDIB;

type
  EDIBImageListError = class(Exception);
  TDIBOperation = (doRemove, doChange);
  TDIBImageRetrieval = (irInternal, irLoadOnStart, irLoadOnDemand);
  TDIBOperationEvent = procedure(Sender: TObject; Index: Integer;
    Operation: TDIBOperation) of object;
  TDIBTranslateImagePathEvent = procedure (Sender: TObject; var ImagePath: string) of object;

  TCustomDIBImageList = class;

  TDIBImagesItemClass = class of TDIBImagesItem;

  TDIBImagesItem = class(TCollectionItem)
  private
    FDIB: TMemoryDIB;
    FImportedFrom: string;
    FDisplayName: string;
    FDIBLoaded: Boolean;
    FImageRetrieval: TDIBImageRetrieval;
    FOnTranslateImagePath: TDIBTranslateImagePathEvent;
    procedure ImportImages;
    procedure ReadTemplateFilename(Reader: TReader);
    function GetDIB: TMemoryDIB;
    procedure SetDIB(const Value: TMemoryDIB);
    procedure WriteTemplateFilename(Writer: TWriter);
    procedure SetImageRetrieval(const Value: TDIBImageRetrieval);
  protected
    procedure DefineProperties(Filer: TFiler); override;
    function GetDIBClass: TMemoryDIBClass; virtual;
    function GetDisplayName: string; override;
    procedure ImageChanged(Sender: TObject); virtual;
    procedure SetDisplayName(const Value: string); override;
    procedure SetIndex(Value: Integer); override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
  published
    property ImageRetrieval: TDIBImageRetrieval read FImageRetrieval write SetImageRetrieval default irInternal;
    property DIB: TMemoryDIB read GetDIB write SetDIB;
    property DisplayName;
    property OnTranslateImagePath: TDIBTranslateImagePathEvent read FOnTranslateImagePath write FOnTranslateImagePath;
  end;

  TDIBImages = class(TOwnedCollection)
  private
    { Private declarations }
    FOwner: TComponent;
    function GetItem(Index: Integer): TDIBImagesItem;
    procedure SetItem(Index: Integer; Value: TDIBImagesItem);
  protected
    procedure ImageChanged(Index: Integer; Operation: TDIBOperation); virtual;
    procedure ImageMoved(FromIndex, ToIndex: Integer); virtual;
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TComponent; AClass: TDIBImagesItemClass);
    destructor Destroy; override;


    function Add: TDIBImagesItem;
    function AddTemplate(const GUID: string; const Index: Integer): TDIBImagesItem;
    function FindItemByName(AName: string): TDIBImagesItem;
    function ItemByName(AName: string): TDIBImagesItem;

    property Items[Index: Integer]: TDIBImagesItem read GetItem write SetItem; default;
  published
  end;

  TDIBImageLink = class(TPersistent)
  private
    FOwner: TComponent;
    FDIBImageList: TCustomDIBImageList;
    FDIBIndex: Integer;
    FOnImageChanged: TDIBOperationEvent;
    procedure UnlinkNotification;
    procedure SetDIBImageList(const Value: TCustomDIBImageList);
    procedure SetDIBImageIndex(const Value: Integer);
  protected
    procedure AssignTo(Dest: TPersistent); override;
    procedure ListChanged(Index: Integer; Operation: TDIBOperation); virtual;
  public
    constructor Create(AOwner: TComponent); virtual;
    destructor Destroy; override;

    function GetImage(var ResultPic: TMemoryDIB): Boolean;
    function Valid: Boolean;

    property OnImageChanged: TDIBOperationEvent read FOnImageChanged write FOnImageChanged;
  published
    property DIBImageList: TCustomDIBImageList read FDIBImageList write SetDIBImageList;
    property DIBIndex: Integer read FDIBIndex write SetDIBImageIndex;
  end;

  TCustomDIBImageList = class(TComponent)
  private
    { Private declarations }
    FDIBImages: TDIBImages;
    FLinkList: TList;
    FDuplicateDIB,
    FUniqueDIB: TMemoryDIB;
  protected
    { Protected declarations }
    procedure AddLink(Link: TDIBImageLink); virtual;
    function GetItemClass: TDIBImagesItemClass; dynamic;
    procedure ImageChanged(Sender: TObject; Index: Integer; Operation: TDIBOperation);
      virtual;
    procedure ImageMoved(FromIndex, ToIndex: Integer); virtual;
    procedure Loaded; override;
    procedure RemoveLink(Link: TDIBImageLink); virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    function Get(Index: Integer): TMemoryDIB;
    function GetUnique(Index: Integer): TMemoryDIB;

    function GetImage(Index: Integer; var ResultPic: TMemoryDIB): Boolean;
    function ImageByName(DisplayName: string): TMemoryDIB;
    function IsIndexValid(Index: Integer): Boolean;

    property Image[Index: Integer]: TMemoryDIB read Get; default;
  published
    { Published declarations }
    property DIBImages: TDIBImages read FDIBImages write FDIBImages; 
  end;

  TDIBImageList = class(TCustomDIBImageList)
  published
  end;


implementation

type
  THackPropertyDIB = class(TMemoryDIB);

  { TDIBImagesItem }

constructor TDIBImagesItem.Create(Collection: TCollection);
begin
  inherited;
  FDIB := GetDIBClass.Create(1, 1);
  THackPropertyDIB(FDIB).OnChange := ImageChanged;
  FDisplayName := inherited GetDisplayName;
  FImportedFrom := '';
  FImageRetrieval := irInternal;
  FDIBLoaded := False;
end;

procedure TDIBImagesItem.DefineProperties(Filer: TFiler);
begin
  inherited;
  Filer.DefineProperty('TemplateFilename', ReadTemplateFilename,
    WriteTemplateFilename, (FImportedFrom <> ''));
end;

destructor TDIBImagesItem.Destroy;
var
  OldIndex: Integer;
  DIBImages: TDIBImages;
begin
  OldIndex := Self.Index;
  DIBImages := nil;
  if Collection <> nil then DIBImages := TDIBImages(Collection);
  FDIB.Free;
  inherited;

  if DIBImages <> nil then
    DIBImages.ImageChanged(OldIndex, doRemove);
end;

function TDIBImagesItem.GetDisplayName: string;
begin
  Result := FDisplayName;
end;

procedure TDIBImagesItem.ImageChanged(Sender: TObject);
begin
  if Collection <> nil then
    TDIBImages(Collection).ImageChanged(Self.Index, doChange);
end;

procedure TDIBImagesItem.ReadTemplateFilename(Reader: TReader);
begin
  FImportedFrom := Reader.ReadString;
end;

procedure TDIBImagesItem.SetDIB(const Value: TMemoryDIB);
begin
  FDIB.Assign(Value);
end;

procedure TDIBImagesItem.SetDisplayName(const Value: string);
begin
  FDisplayName := Value;
  inherited;
end;

procedure TDIBImagesItem.WriteTemplateFilename(Writer: TWriter);
begin
  Writer.WriteString(FImportedFrom);
end;

procedure TDIBImagesItem.SetIndex(Value: Integer);
var
  FromIndex: Integer;
begin
  FromIndex := Index;
  inherited;
  if Collection <> nil then
    TDIBImages(Collection).ImageMoved(FromIndex, Value);
end;

function TDIBImagesItem.GetDIB: TMemoryDIB;
begin
  Result := FDIB;
  if not FDIBLoaded then
    ImportImages;
end;

function TDIBImagesItem.GetDIBClass: TMemoryDIBClass;
begin
  Result := TMemoryDIB;
end;


procedure TDIBImagesItem.SetImageRetrieval(const Value: TDIBImageRetrieval);
begin
  FImageRetrieval := Value;
  FDIB.SaveImageData := (Value = irInternal);
end;

procedure TDIBImagesItem.ImportImages;
  function GetFilename(const AFilename: string): string;
  var
    Path: string;
  begin
    Result := AFilename;
    if (Result <> '') and Assigned(FOnTranslateImagePath) then
    begin
      Path := ExtractFilePath(AFilename);
      FOnTranslateImagePath(Self, Path);
      if Path <> '' then
        Result := IncludeTrailingBackslash(Path) + ExtractFilename(AFilename)
      else
        Result := ExtractFilename(AFilename);
    end;
  end;

var
  Filename: string;
begin
  if not FDIBLoaded then
  begin
    if ImageRetrieval = irInternal then
      FDIBLoaded := True
    else
    if FDIB.ImageFilename <> '' then
    try