jvimagelist.pas

East make Tray Icon in delphi

{-----------------------------------------------------------------------------
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: JvImageList.pas, released on 2003-10-09

The Initial Developers of the Original Code are: Andreas Hausladen <Andreas dott Hausladen att gmx dott de>
Copyright (c) 2003 Andreas Hausladen
All Rights Reserved.
Portions created by Uwe Schuster are Copyright (C) 2003, 2004 Uwe Schuster.

Contributor(s):
Uwe Schuster [jedivcs att bitcommander dott de]

You may retrieve the latest version of this file at the Project JEDI's JVCL home page,
located at http://jvcl.sourceforge.net

Known Issues:
  ImageKind ikMappedResourceBitmap is not support so far
-----------------------------------------------------------------------------}
// $Id: JvImageList.pas,v 1.47 2005/02/17 10:20:37 marquardt Exp $

unit JvImageList;

{$I jvcl.inc}

interface

uses
  {$IFDEF UNITVERSIONING}
  JclUnitVersioning,
  {$ENDIF UNITVERSIONING}
  Windows,
  {$IFDEF MSWINDOWS}
  CommCtrl,
  {$ENDIF MSWINDOWS}
  SysUtils, Classes, Graphics, Controls, ImgList;

type
  TJvImageListMode = (imClassic, imPicture, imResourceIds, imItemList);
  TJvImageListTransparentMode = (tmNone, tmAuto, tmColor);

  EJvImageListError = class(Exception);

  TJvImageListItemKind = (ikResourceBitmap, ikMappedResourceBitmap, ikInlineBitmap);

  TJvImageListItem = class(TCollectionItem)
  private
    FBitmap: TBitmap;
    FKind: TJvImageListItemKind;
    FResourceName: string;
    FTransparentColor: TColor;
    procedure AddToImageList(AImageList: TImageList);
    procedure BitmapChanged(Sender: TObject);
    function GetImageList: TImageList;
    procedure SetBitmap(ABitmap: TBitmap);
    procedure SetKind(AKind: TJvImageListItemKind);
    procedure SetResourceName(const AResourceName: string);
    procedure SetTransparentColor(AColor: TColor);
    procedure UpdateImageListItem(AImageList: TImageList; AIndex: Integer);
  protected
    function GetDisplayName: string; override;
    procedure SetIndex(Value: Integer); override;
  public
    constructor Create(Collection: TCollection); override;
    destructor Destroy; override;
    procedure UpdateImageList;
  published
    property Kind: TJvImageListItemKind read FKind write SetKind;
    property TransparentColor: TColor read FTransparentColor write
      SetTransparentColor;
    property Bitmap: TBitmap read FBitmap write SetBitmap;
    property ResourceName: string read FResourceName write SetResourceName;
  end;

  TJvImageListItems = class(TOwnedCollection)
  private
    function GetItem(AIndex: Integer): TJvImageListItem;
    procedure SetItem(AIndex: Integer; Value: TJvImageListItem);
  protected
    {$IFDEF COMPILER5}
    function Owner: TPersistent;
    {$ENDIF COMPILER5}
    procedure Update(Item: TCollectionItem); override;
  public
    constructor Create(AOwner: TComponent);
    function Add: TJvImageListItem;
    property Items[AIndex: Integer]: TJvImageListItem read GetItem write SetItem; default;
  end;

  TJvImageList = class(TImageList)
  private
    FUpdateLock: Integer;
    FModified: Boolean;

    FItems: TJvImageListItems;
    FTransparentMode: TJvImageListTransparentMode;
    FTransparentColor: TColor;
    FPicture: TPicture;
    FFileName: TFileName;
    {$IFDEF VCL}
    FPixelFormat: TPixelFormat;
    {$ENDIF VCL}
    FResourceIds: TStrings;
    FMode: TJvImageListMode;

    procedure SetFileName(const Value: TFileName);
    procedure SetItems(AItems: TJvImageListItems);
    procedure SetPicture(Value: TPicture);
    procedure SetTransparentMode(Value: TJvImageListTransparentMode);
    procedure SetTransparentColor(Value: TColor);
    {$IFDEF VCL}
    procedure SetPixelFormat(const Value: TPixelFormat);
    procedure SetInternalHandle(Value: THandle);
    {$ENDIF VCL}
    procedure SetResourceIds(Value: TStrings);
    procedure SetMode(const Value: TJvImageListMode);

    procedure SlicePictureToImageList;
    procedure ResourceIdsToImageList;
    procedure DoLoadFromFile;
  protected
    procedure ItemListError;
    procedure DefineProperties(Filer: TFiler); override;
    procedure InitializeImageList; virtual; // called by Initialize (VCL and VCLX)
    {$IFDEF VCL}
    procedure Initialize; override;
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    procedure Initialize(const AWidth, AHeight: Integer); override;
    {$ENDIF VisualCLX}
    procedure Change; override;
    procedure DataChanged(Sender: TObject); virtual;
    procedure UpdateImageList;
    {$IFDEF VCL}
    procedure HandleNeeded; virtual;
    procedure CreateImageList; virtual;
    property FHandle: THandle write SetInternalHandle;
    {$ENDIF VCL}
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure BeginUpdate;
    procedure EndUpdate;
    {$IFDEF VCL}
    procedure DrawIndirect(ImageListDrawParams: TImageListDrawParams);
      // DrawIndirect fills the .cbSize and .himl field.
    function Merge(Index1: Integer; ImageList: TImageList; Index2: Integer;
      dx, dy: Integer): TImageList;
      // Merge creates a new TJvImageList and returns it. It is up to the user
      // to release this new image list.
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    procedure GetIcon(Index: Integer; Ico: TIcon);
    {$ENDIF VisualCLX}
    procedure SaveToFile(const FileName: string);
    procedure SaveToStream(Stream: TStream); virtual;
    procedure LoadFromFile(const FileName: string);
    procedure LoadFromStream(Stream: TStream); virtual;

    { imItemList }
    // (usc) DeleteItem, ClearItem and GetItemInfoStr are obsolete because the are
    //       directly mapped to Items
    procedure AddItem(ABitmap: TBitmap; ATransparentColor: TColor); overload;
      // AddItem adds a bitmap to the ItemList with ATransparentColor as
      // transparent color. If the image list mode is not imItemList the image
      // list is cleared and the mode is set to imItemList.
    procedure AddItem(const AResourceName: string; ATransparentColor: TColor); overload;
      // AddItem adds the resource AResourceName from the HInstance libarary to
      // the ItemList with ATransparentColor as transparent color. If the image
      // list mode is not imItemList the image list is cleared and the mode is
      // set to imItemList.
    procedure DeleteItem(AIndex: Integer);
      // DeleteItem deletes the ItemList item that is identified by AIndex.
      // When the ImageList is not in imItenList mode the method raises an
      // RJvImageListError.
    procedure ClearItems;
      // ClearItems clears the ItemList. When the ImageList is not in imItemList
      // mode the method raises an RJvImageListError.
    function GetItemInfoStr(AIndex: Integer): string;
      // GetItemInfoStr returns the info string of the ItemList item that is
      // identified by AIndex. When the ImageList is not in imItenList mode the
      // method raises an RJvImageListError.
  published
    property Mode: TJvImageListMode read FMode write SetMode default imPicture;
      // Mode specifies which property the component should use.
      //   imClassic: be a normal TImageList
      //   imPicture: split the image in Picture
      //   imResourceIds: load the images by ResourceIds
      //   imItemList: the AddItem, DeleteItem, ClearItems and GetItemInfoStr methods are available

    {$IFDEF VCL}
    property PixelFormat: TPixelFormat read FPixelFormat write SetPixelFormat default pfDevice;
      // PixelFormat is the color resolution of the image list. pf1bit and
      // pfCustom are not supported.
      // WARNING: pf32bit works under Windows XP only.
    {$ENDIF VCL}
    property TransparentMode: TJvImageListTransparentMode read FTransparentMode write SetTransparentMode default
      tmColor;
      // TransparentMode is used for adding the bitmaps from Picture or
      // ResourceIds.
      //   tmNone: no mask
      //   tmAuto: use the pixel at the left bottom edge
      //   tmColor: use TransparentColor
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor default clFuchsia;
      // TransparentColor specifies the color that is used as the MaskColor
      // when spitting the graphic in Picture.Graphic or adding the Resource
      // bitmaps to the image list.

    property FileName: TFileName read FFileName write SetFileName;
      // (only for designtime)
      // FileName specifies a graphic file that is available on the developer's
      // system which contains the bitmaps which can be exported by the
      // ImageList. The Data is copied to Picture.Graphic. If the file does not
      // exists at design time the stored Picture.Graphic is used.
    property Picture: TPicture read FPicture write SetPicture;
      // Picture.Graphic is updated at design time by the graphic file specified
      // by FileName. The Picture property is only loaded into the image list if
      // the Mode is imPicture.
    property ResourceIds: TStrings read FResourceIds write SetResourceIds;
      // ResourceIds contains the resource ids of the bitmaps to load. Allowed
      // are RCDATA (a bitmap file) and BITMAP. ResourceIds property is only
      // loaded into the image list if Mode is imResourceIds.
    property Items: TJvImageListItems read FItems write SetItems;
  end;

{$IFDEF VCL}
function CreateImageListHandle(Width, Height: Integer; PixelFormat: TPixelFormat;
  Masked: Boolean; AllocBy: Integer): THandle;
{$ENDIF VCL}

function LoadImageListFromBitmap(ImgList: TCustomImageList; const Bitmap: TBitmap;
  MaskColor: TColor = clFuchsia; AutoMaskColor: Boolean = False): Integer; overload;
function LoadImageListFromBitmap(ImgList: TCustomImageList; const Bitmap: TBitmap;
  MaskBitmap: TBitmap): Integer; overload;

{$IFDEF UNITVERSIONING}
const
  UnitVersioning: TUnitVersionInfo = (
    RCSfile: '$RCSfile: JvImageList.pas,v $';
    Revision: '$Revision: 1.47 $';
    Date: '$Date: 2005/02/17 10:20:37 $';
    LogPath: 'JVCL\run'
  );
{$ENDIF UNITVERSIONING}

implementation

uses
  Consts, TypInfo,
  {$IFDEF VCL}
  ActiveX,
  {$ENDIF VCL}
  {$IFDEF COMPILER5}
  JvJclUtils, // SameFileName() for Delphi 5
  {$ENDIF COMPILER5}
  JvJVCLUtils, JvResources;

resourcestring
  // (usc) there is no real need to move this string to JvResource.pas because
  //       hopefully ikMappedResourceBitmap will be supported soon
  RsENotSupportedItemKind = 'The item kind %s is not supported so far.';

{$IFDEF UNIX}
const
  RT_RCDATA = PChar(10);
{$ENDIF UNIX}

{$IFDEF VCL}

{------------------------------------------------------------------------------}
{ Here we inject a jump to our HandleNeededHook into the static
  TCustomImageList.HandleNeeded method. }

type
  TCustomImageListAccessProtected = class(TCustomImageList);

  // we need direct access to the FHandle field because the Handle property
  // calls the Changed method that calls HandleNeeded that calls SetHandle, ...
  TImageListPrivate = class(TComponent)
  protected
    FHeight: Integer;
    FWidth: Integer;
    FAllocBy: Integer;
    FHandle: HIMAGELIST;
  end;

  TJumpCode = packed record
    Jump: Byte;
    Offset: Integer;
  end;

var
  HandleNeededHookInstalled: Boolean = False;
  SavedNeededHookCode: TJumpCode;

procedure HandleNeededHook(Self: TImageList);
begin
  if Self is TJvImageList then
    TJvImageList(Self).HandleNeeded
  else
  begin
    if not Self.HandleAllocated then
    begin
      TImageListPrivate(Self).FHandle := CreateImageListHandle(Self.Width, Self.Height,
        pfCustom, Self.Masked, Self.AllocBy);
      if not Self.HandleAllocated then
        raise EInvalidOperation.CreateRes(@SInvalidImageList);
      if Self.BkColor <> clNone then
        Self.BkColor := Self.BkColor;
    end;
  end;
end;

procedure UninstallHandleNeededHook;
var
  OrgProc: Pointer;
  n: Cardinal;
begin
  if HandleNeededHookInstalled then
  begin
    OrgProc := @TCustomImageListAccessProtected.HandleNeeded;

    if WriteProcessMemory(GetCurrentProcess, OrgProc, @SavedNeededHookCode, SizeOf(SavedNeededHookCode), n) then
    begin
      HandleNeededHookInstalled := False;
      FlushInstructionCache(GetCurrentProcess, OrgProc, SizeOf(SavedNeededHookCode));
    end;
  end;
end;

procedure InstallHandleNeededHook;
var
  OrgProc: Pointer;
  NewProc: Pointer;
  Code: TJumpCode;
  n: Cardinal;
begin
  if not HandleNeededHookInstalled then
  begin
    OrgProc := @TCustomImageListAccessProtected.HandleNeeded;
    NewProc := @HandleNeededHook;

    Code.Jump := $E9;
    Code.Offset := Integer(NewProc) - Integer(OrgProc) - SizeOf(Code);

    if ReadProcessMemory(GetCurrentProcess, OrgProc, @SavedNeededHookCode, SizeOf(SavedNeededHookCode), n) then
      if WriteProcessMemory(GetCurrentProcess, OrgProc, @Code, SizeOf(Code), n) then
      begin
        HandleNeededHookInstalled := True;
        FlushInstructionCache(GetCurrentProcess, OrgProc, SizeOf(Code));
      end;
  end;
end;

{------------------------------------------------------------------------------}

function CreateImageListHandle(Width, Height: Integer; PixelFormat: TPixelFormat;
  Masked: Boolean; AllocBy: Integer): THandle;
var
  Flags: Cardinal;
begin
  if PixelFormat = pfDevice then
    PixelFormat := ScreenPixelFormat;

  case PixelFormat of
    pf4bit:
      Flags := ILC_COLOR4;
    pf8bit:
      Flags := ILC_COLOR8;
    pf15bit, pf16bit:
      Flags := ILC_COLOR16;
    pf24bit:
      Flags := ILC_COLOR24;
    pf32bit:
      Flags := ILC_COLOR32;
  else
    Flags := ILC_COLORDDB;
  end;
  if Masked then
    Flags := Flags or ILC_MASK;

  Result := ImageList_Create(Width, Height, Flags, AllocBy, AllocBy);
end;

{$ENDIF VCL}

//=== { TJvImageListItem } ===================================================

constructor TJvImageListItem.Create(Collection: TCollection);
begin
  inherited Create(Collection);

  FBitmap := TBitmap.Create;
  FBitmap.OnChange := BitmapChanged;
  FKind := ikResourceBitmap;
  FResourceName := '';
  FTransparentColor := clFuchsia;
  if GetImageList <> nil then
    AddToImageList(GetImageList);
end;

destructor TJvImageListItem.Destroy;
var
  ImageList: TImageList;
begin
  ImageList := GetImageList;
  if Assigned(ImageList) and (Index >= 0) and (ImageList.Count > Index) then
    ImageList.Delete(Index);
  FBitmap.Free;
  inherited Destroy;
end;

procedure TJvImageListItem.AddToImageList(AImageList: TImageList);
var
  Bitmap: TBitmap;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := AImageList.Width;
    Bitmap.Height := AImageList.Height;
    AImageList.AddMasked(Bitmap, FTransparentColor);